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1.0  INTRODUCTION 


The  Articulated  Total  Body  (ATB)  Model  is  used  at  the  Armstrong 
Aerospace  Medical  Research  Laboratory  (AAMRL)  for  predicting  gross  human 
body  response  in  various  dynamic  environments,  especially  aircraft 
ejection  with  windblast  exposure.  Aerodynamic  force  application  and  a 
harness  belt  capability  were  added  to  the  Crash  Victim  Simulation  (CVS) 
Program  (Ref  1)  by  Calspan  Corporation  in  1975  for  AMR L  (Ref  2),  and  the 
resulting  program  became  known  as  the  ATB  model.  In  1980,  Calspan  made 
a  number  of  modifications  to  the  ATB  model  combining  it  with  the  then 
current  3-D  Crash  Victim  Simulation  program  to  form  the  ATB-II  model 
(Ref  3).  Complete  documentation  of  the  ATB-II  program  was  performed  by 
Calspan  Corp.  (Ref  4).  A  new  version,  ATB-II1,  was  generated  which 
included  the  improvements  made  by  J&J  Technologies  Inc  to  model  the  body 
response  to  windblast  for  AMRL  (Ref  5). 

A  number  of  efforts  have  been  made  to  improve  various  aspects  of  the 
ATB -I I I  model,  with  emphasis  on  its  capability  to  simulate  aircraft 
ejection  with  windblast  exposure  and  complex  automobile  accidents. 

This  volume.  Programmer's  Guide,  contains  a  complete  listing  of  the 
ATB-IV.O  source  code  and  other  information  about  the  FORTRAN  program. 
Much  of  this  volume  is  a  reprinting  with  modifications  and  updates  of 
Volume  4  of  Calspan' s  report  on  the  CVS  (Ref  4). 

A  list  of  the  variables  contained  in  the  labeled  COMMON  blocks  and  a 
brief  description  of  each  variable  are  in  section  Two  of  this  volume. 
Cross  reference  charts  for  the  subroutines  and  COMMON  blocks  are  in 
Section  Three,  while  a  list  of  all  the  subroutines  is  in  Section  Four. 
Section  Five  contains  a  complete  listing  of  the  ATB-IV.O  source  code. 


2.0  COMMON  BLOCK  VARIABLES 


This  section  contains  a  list  of  all  of  the  variables  contained  in  the 
labeled  COMMON  blocks  of  the  ATB  program.  They  are  listed  in  the 
alphabetical  order  of  the  COMMON  block  names.  Following  each  variabl 
is  its  dimension,  if  any,  and  a  short  definition.  If  the  variable  is 
supplied  as  ATB  program  input,  references  are  indicated  to  the  input 
card  number  and  a  more  complete  definition  may  be  found  in  the  input 
description  contained  in  Volume  2. 


COMMON  /ABDATA/ 


ZDEP 

(3,5) 

Deployment  point  of  airbag  in  local  reference 
of  1st  reaction  panel  (Card  D.4.c) 

DBR 

(3,3,5) 

Direction  cosine  matrix  of  airbag  relative  to 

vehicle 

PPVCTR 

(3,5) 

Vector  along  which  airbag  c.g.  lies  during  baj 

inflation 

DEPLOY 

(3,5) 

Location  of  deployment  point 

AB 

(3,5) 

Semiaxes  of  fully  inflated  ellipsoid  airbag 

(Cards  D.4.b) 

B 

(9,4,5) 

3X3  matrix  defining  ellipsoid  XTBX=1  for 
reaction  panel 

ZR 

(3,4,5) 

Location  of  panel  c.g.  in  vehicle  reference 

(Card  D.4.h) 

BFB 

(3,4,5) 

c.g.  offset  of  reaction  panel  (Card  D.4.g) 

DRR 

(9,4,5) 

Direction  cosine  matrix  of  reaction  panel 

relative  to  inertial  reference 

VBAGG 

(5) 

Geometric  volume  of  fully  inflated  airbag 

VSCS 

(5) 

Coefficient  of  sliding  friction  of  the  airbag 

(Card  D.4.f) 

SPRK 

(5) 

Spring  constant  of  a  linear  spring  used  to 

stipulate  attachment  of  the  airbag  at  the 
deployment  point  (Card  D.4.f) 

CK 

(5) 

Parameter  used  to  stabilize  airbag  numerical 
integration  (Card  D.4.f) 

CMASS 

(5) 

Multiplier  to  increase  or  decrease  the  mass  of 

the  airbag  to  artificially  dampen  the 
integrated  airbag  motion  (Card  D.4.f) 

CYMIN 

(5) 

Mass  flow  into  the  airbag 

CYMOUT 

(5) 

Mass  flow  out  of  the  airbag 

BAGPV 

(5) 

Undeformed  airbag  volume 

PD 

(5) 

Airbag  pressure  differential 

VBAG 

(5) 

Airbag  volume 

VOLBP 

(5) 

Total  volume  of  intersection  or  airbag 

with  contacting  segments  and  panels 

PCYV 

(5) 

Volume  of  mass  flow  into  airbag  at  atmospheric 
pressure  at  time  if  initial  inflation 

PCYMIN 

(5) 

Mass  flow  into  airbag  at  time  of  initial 

full  inflation 

PVBAG 

(5) 

Airbag  volume  •’t  time  if  initial  inflation 

TV1 

(3,4,5) 

Memory  for  Subroutines  INTERS  and  EDEPTH 

for  airbag-panel  ellipsoid  contacts 

TV  2 

(3,10,5) 

Memory  for  Subroutines  INTERS  and  EDEPTH 

for  airbag-segment  ellipsoid  contacts 

SWITCH 


(5) 


Reciprocal  density  of  airbag  at  time  of 
initial  full  inflation 


( 

* 

! 
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PYMOUT 

(5) 

Mass  flow  out  of  airbag  at  time  of  initial 

full  inflation 

SCALE 

(5) 

Ratio  (0-1)  of  linear  dimensions  of  airbag 
to  fully  inflated  airbag 

PREVT 

Value  of  TIME  at  previous  airbag  integration 

step 

I  FULL 

(6) 

Indicates  that  airbag  is  fully  inflated 

COMMON 

/CDINT  / 

UU 

(4) 

Constants  computed  by  Subroutine  TRIGFS 

GH 

(3,4)  J 

f 

valid  for  the  upcoming  integrator  time  step 

E 

(3,240)  " 

i 

FF 

(5,240) 

Intermediate  storage  of  function 

GG 

(5,240) 

\  evaluations  in  Subroutine  DINT 

Y 

(5,240) 

U 

(5,240)  ^ 

H 


Current  value  of  the  independent  variable 
step  size  in  Subroutine  DINT 


HPRINT 

Saved  value  of  H  while  integrating  to 

print  point  only 

TSAVE 

Set  to  zero  or  H  to  reset  integrator 

TPRINT 

Value  of  next  print  time  point 

TSTART 

Start  time  of  an  integration  step 

ICNT 

Count  of  successive  integration  steps  for 

which  convergence  has  been  successful 

1DBL 

Maximum  value  for  ICNT  before  test  to  double 

step  size  is  performed 

I  FLAG 

Currently  not  used  by  program 

COMMON 

/CEULER/ 

I  EULER 

(30) 

Current  lock-unlock  conditions  for  an  Euler 

joint  (see  identification  under  IPIN  on 

Cards  B.2) 

H1R 

(3,3,90) 

Direction  cosine  matrix  defining  orientation 

of  axes  of  an  Euler  joint 

ANG 

(3,30) 

Angles  of  orientation  of  an  Euler  joint 

ANGD 

(3,30) 

Time  derivative  of  orientation  angles  of  an 

Euler  joint 

FE 


(3,30) 


Components  of  torque  acting  on  an  Euler  joint 
in  joint  reference 


1 

% 

I 
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CONST 


(3,30) 


(5,30) 


COMMON  / CMATRX/ 


(3,30) 


(3,30) 


(3,12) 


(3,3,60) 


(3,3,60) 


(3,30) 


(3,30) 


(3,3,30) 


Components  of  torque  acting  on  an  Euler  joint 
in  inertial  reference 

Memory  of  previous  angles  of  orientation  of  an 
Euler  joint 


Right  hand  side  of  system  of  equations 
®11*  +  B^w  +  ®13  f  “  V} 

Right  hand  side  of  system  of  equations 
B22X  +  ®24  t  *  V2 

Right  hand  side  of  system  of  equations 
b31  *  +  B32*  +  ®35  q  “  v3 

Subarray  elements  of  B12 
Subarray  elements  of  A22 

Components  of  force  acting  on  the  joints  from 
the  solution  of  system  equations 

Components  of  torque  acting  on  the  joints  from 
the  solution  of  system  equations 

Relative  angular  velocity  of  each  joint 

Subarray  elements  of  An 


COMMON  / CNSNTS/ 


FORTRAN  Subroutine  Library  value  for  Pi, 
computed  by  PI  ■  DAT AN 2(0 .0D0, -1 .0D0) 


PI 


RADIAN 

G 

THIRD 

EPS 


Number  of  radians  per  degree  (PI/180) 

Resultant  of  gravity  vector  (Card  A.3) 

Double  precision  value  for  1/3 

(24)  Values  of  negative  powers  of  ten,  computed 

by  EPS(I)  -  10. 0D0 **(-!) 


UNITL 

UNITM 

UNITT 

GRAVITY 

TWOPI 


I/O  unit  of  length  (Card  A.3) 

I/O  unit  of  force  of  mass  (Card  A.3) 

I/O  unit  of  time  (Card  A.3) 

(3)  Components  of  gravity  vector  (Card  A.3) 

2.0*PI 


COMMON  / CNTSRF/ 


h 


PL  (24,30)  Array  of  parameters  that  define  each  plane 

(See  Table  1  in  Volume  1) 

BELT  (20,6)  Array  of  parameters  that  define  each  belt 

(Cards  D.3.b-D.3.c) 

TPTS  (6,8)  Location  of  belt  tangent  points  in  inertial 

reference 


BD 


(24,40) 


Array  of  parameters  that  define  each 
ellipsoid 


COMMON  /COMAIN/ 


VAR 

(240) 

Integrated  function  values  supplied  by 

Subroutine  DINT  to  Subroutine  PDADX 

DER 

(240) 

Function  derivatives  supplied  by  Subroutine 

PDAUX  to  Subroutine  DINT 

DT 

Time  interval  for  main  program  output  time 
points  (Card  A. 4) 

HO 

Initial  integrator  step  size  (Card  A. 4) 

HMAX 

Maximum  integrator  step  size  (Card  A. 4) 

HMIN 

Minimum  integrator  step  size  (Card  A. 4) 

RSTIME 

Restart  time  (Card  A.l.a) 

I  STEP 

Current  integration  step  number 

N STEPS 

No.  of  integration  steps  for  duration  of 

simulation  (Card  A. 4) 

NDINT 

No.  of  iterations  for  convergence  test  for 

Subroutine  DINT  (Card  A. 4) 

NEQ 


Total  number  of  functions  integrated  by 
Subroutine  DINT 


IRS  IN 


Restart  input  unit  no.  (Card  A.l.a) 


IRSOUT  Restart  output  unit  no.  (Card  A.l.a) 

COMMON  /CONTRL/ 

TIME  Current  simulation  time 

NSEG  Number  of  body  segments  of  crash  victim, 

max-30  (Card  B.l) 

NJNT  Number  of  joints,  max-30  (Card  B.l) 

NFL  Number  of  plane  definitions  supplied  on 

Cards  D.2,  max-30  (Card  D.l) 

NBLT  Number  of  belt  definitions  supplied  on 

Cards  0.3,  max- 8  (Card  D.l) 

NBAG  Number  of  airbag  definitions  supplied 

Cards  D.4,  max-5  (Card  D.l) 

NVQ1  Segment  identification  number  for  the  vehicle 

(NVEH-NSEG+number  of  vehicles) 

NGRND  Segment  identification  number  for  the  ground 

(NGRND-NSEG+NBAG+number  of  vehicles+l) 

NS  Number  of  singular  segments,  i.e.,  V  or  at 

least  one  component  of  Hi  I  is  aero 

NQ  Number  of  contraints  supplied  on  Cards  D.6, 

final  max  -12  (Card  D.l) 


NSD 


Number  of  spring  clampers  supplied  on  Cards 
D.8,  max=20  (Card  D.l) 


NFLX 


Total  number  of  interior  segments  of  all 
flexible  elements. 


NHBNSS 


Number  of  harness-belt  systems  supplied  on 
Cards  F.8,  max=5  (Card  D.l) 


NHINDf 


Number  of  wind  force  functions  supplied  on 
Cards  E.6  (Card  D.l) 


NJNTF  Number  of  joint  restoring  force  functions 

supplied  on  Cards  E.7  (Card  D.l) 

NP&T  (36)  Indicators  that  control  optional  output  of 

the  program  (Card  A. 5) 


NPG 


Current  page  number  of  main  output 


COMMON  / CSTBNT/ 


A13  (3,3,24)  Subarray  elements  of  Ajj  for  system  of 

equations 

Mi’  +  Ajif  +  A^q  -  Uj 

A23  (3,3,24)  Subarray  elements  of  A23  for  system  of 

equations 

$w  +  A£jf  +  A22*  +  ^23*1  "  ^2 

B31  (3,3,24)  Subarray  elements  of  B31  for  system  of 

equations  defining  constraints 


B32 

(3,3,24) 

Subarray  elements  of  B32  for  system  of 
equations  defining  constraints 

HHT 

(3,3,12) 

Array  hhT  or  I-hhT  for  each  constraint 

RK1 

(3,12) 

Specified  point  on  segment  number  KQ1 

(Card  D.6) 

KK2 

(3,12) 

Specified  point  on  segment  number  KQ2 

(Card  D.6) 

QQ 

(3,12) 

Computed  force  necessary  to  maintain  each 

constraint 

TQQ 

(3,12) 

Normal  vector  at  the  point  of  contact  for  each 

constraint 

8QQ 

(3,12) 

R  dot  term  for  constraint  equation 

HQQ 

(3,12) 

Reference  vector  at  point  of  constraint 

SQQ 

(3,12) 

R  term  for  constraint  equation 

CFQQ 

(12) 

Coefficient  of  friction  for  each  constraint 

KQ1 

(12) 

Segment  identification  number  of  the  1st 
specified  point  (Card  D.6) 

KQ2 

(12) 

Segment  identification  number  of  the  2nd 
specified  point  (Card  D.6) 

KQTYPE 

(12) 

Constraint  type  number  (Card  D.6) 

COMMON  /CYDATA/ 


Gas  supply  actuator  firing  time  (Card  D.4.d) 

Atmospheric  pressure  (Card  D.4.d) 

Initial  gas  supply  pressure  (Card  D.4.d) 

Initial  gas  supply  temperature  (Card  D.4.d) 

Gas  supply  reservoir  volume  (Card  D.4.d) 

Sonic  throat  discharge  coefficient 
(Card  D.4.e) 

Ratio  of  specific  heats  of  supply  gas 
(Card  D.4.e) 

Specific  gas  constant  (Card  D.4.e) 

Sonic  throat  area  (Card  D.4.e) 

Vent  pressure  of  the  exhaust  orifice 

Exhaust  orifice  discharge  coefficient 
(Card  D.4.e.) 

Exhaust  orifice  area  (Card  D.4.f) 

Initial  air  cylinder  gauge  supply  pressure 
Speed  of  sound 
Characteristic  length 


CYC 

(5) 

Air  cylinder  gas  constant 

CYBHOO 

(5) 

Initial  air  cylinder  density 

CYVMAX 

(5) 

Air  cylinder  maximum  volume 

CYORFC 

(5) 

Air  cylinder  exhaust  orifice  constant 

CYRHO 

(5) 

Density  of  air  cylinder  gas  supply 

CYT 

(5) 

Temperature  of  air  cylinder  gas  supply 

CYP 

(5) 

Pressure  of  air  cylinder  gas  supply 

CYV 

(5) 

Volume  of  air  cylinder  gas  supply  at  standard 

atmospheric  pressure 

COMMON 

/DAMPER/ 

APSDM 

(3,20) 

Attachment  point  in  local  reference  of 
segment  M  for  spring  dampers  (Card  D.8) 

APSDN 

(3,20) 

Attachment  point  in  local  reference  of 
segment  N  for  spring  dampers  (Card  D.8) 

ASO 

(5,20) 

Spring  and  viscous  force  function  coefficient 

(Card  D.8) 

MS  DM 

(20) 

Identification  number  of  segment  M  (Card  D.8) 

MSDN 


(20) 


Identification  number  of  segment  N  (Card  D.8) 


I 


COMMON 

/ DESCRP/ 

PHI 

(3,30) 

Segment  principal  moments  of  inertia 

(Cards  B.2) 

V 

(30) 

Segment  weight  (Cards  B.2) 

RW 

(30) 

Reciprocal  mass  (g/w)  for  each  segment 

SR 

(4,60) 

Joint  locations  in  local  reference  of 

adjacent  segments  (Cards  B.3) 

HA 

(3,60) 

Principal  line  of  joint  from  which  flexure 

angle  is  measured 

H B 

(4,60) 

Perpendicular  to  HA  (pin  axis  if  joint  is 
pinned) 

RPHI 

(3,30) 

Reciprocal  moments  of  inertia  for  each 

segment 

HT 

(3,3,60) 

Principal  axes  of  the  joints 

SPRING 

(5,90) 

Flexural  and  torsional  spring  characteristics 

(Cards  B.4) 

vise 

(7,90) 

Flexural  and  torsional  viscous  characteristics 

(Cards  B.5) 

JNT 

(30) 

Magnitude  indicates  the  segment  identification 

number  that  is  connected  to  segment  J+l  by 
joint  J  (Cards  B.3) 

I  PIN 


(30)  Indicator  of  joint  type  (Card  B.3) 


H 


I  SING 

(30) 

Indicator  (value*l)  that  segment  is  singular 

IGLOB 

(30) 

Input  indicator  (Card  F.4.a)  to  signify  that 
joint  J  is  to  use  the  globalgraphic  option. 

A  nonzero  value  will  be  set  to  index  of 

function  to  be  used. 

JOINTF 

(30) 

The  function  idenfication  number  used  to 

compute  the  joint  restoring  force  (Card  F.5) 

COMMON 

/  FLXBLE/ 

BF 

(4,12,8) 

Coefficients  of  quadratic  function  defining 

relative  orientation  of  interior  segments  of 

flexible  elements 

B42 

(3,3,24) 

Subarray  elements  of  matrix  B42  in  the 
constraint  equations  for  flexible  elements 

V4 

(3,8) 

Right  hand  side  of  the  constraint  equations 

for  flexible  elements. 

NFL  EX 

(3,8) 

The  identification  numbers  of  reference. 

interior  and  terminating  segments  for  each 
interior  segment. 


NFL  EX 


COMMON  /FORCES/ 


PSF 


(7,70)  Array  of  output  values  for  plane-segment 
contacts 


BSF  (4,20) 


Array  of  output  values  for  belt-segment 
contacts 


SSF  (10,40) 


Array  of  output  values  for  segment-segment 
contacts 


BAGSF 

PRJNT 

N  PAN  EL 

NPSF 

NBSF 

NSSF 

NBGSF 


(3,20)  Array  of  output  values  for  airbag-segment 
contacts 

(7,30)  Output  arrays  for  joint  parameters 

(5)  Number  of  reaction  panels  for  each  airbag 
(J-l,  NBAG) 

Number  of  plane-segment  contact  (Max=70) 

Number  of  belt-segment  contacts  (Maxm20) 

Number  of  segment-segment  contacts  (Max=40) 

Number  of  items  to  be  printed  for  airbag- 
segment  contacts  (Maxs20) 


18 


COMMON  /BRNESS/ 


BAR 

(15,100) 

Coordinates  of  points  in  local  reference 

(Cards  F.8.d) 

BB 

(100) 

Lengths  of  individual  belt  segments  between 

reference  points 

BBDOT 

(100) 

Time  derivative  of  belt  segment  lengths 

PLOSS 

(2,100) 

Energy  loss  of  individual  belt  segments 

XLONG 

(20) 

The  initial  slack  of  each  belt  (Cards  F.8.c) 

UTIME 

(2) 

Previous  value  of  TIME  for  Subroutine  HPTDRB 

IBAR 

(5,100) 

Array  of  indicators  containing  KS,  KE,  NF 

index,  NPD  and  NPR  (Cards  F.8.d)  for  each 
point 

NL 

(2,100) 

Pointers  to  the  IBAR  and  N TURNS  arrays  for 

each  point  in  play 

NPTSPB 

(20) 

Number  of  points  per  belt  (Cards  F.8.b) 

NPTPLY 

(20) 

Number  of  points  in  play  per  belt 

N TURNS 

(20) 

Index  to  NTAB  array  defining  the  force 

deflection  functions  for  each  belt 

NBLTPH 


(5) 


Number  of  belts  per  harness  (Card  F.8.a) 


COMMON 

SGTEST 

XTEST 

SEGT 

PEGT 

COMMON 

MNPL 

MNBLT 

MNSEG 

MNBAG 

MFL 


'  INTEST/ 


(3,4,30) 


(3,120) 


(120) 


(120) 


I JBARTZy 


(3,5,30) 


Integrator  convergence  test  input  numbers 
(Cards  B.6) 

Integrator  convergence  test  numbers  setup 
by  PDAUX  for  DINT 

Segment  identification  of  integrator  variabl 

Identification  (ANG  VEL,  ANG  ACC,  LIN  VEL 
or  LIN  ACC)  of  type  of  integrator  variable 


Number  of  segments  to  contact  each  plane 
(Card  F.l.a) 

Number  of  segments  to  contact  each  belt 
(Card  F.2.a) 

Number  of  segments  to  contact  each  segment 
(Card  F.3.a) 

Number  of  segments  to  contact  each  airbag 

Segment  and  ellipsoid  identification  numbers 
for  each  plane-segment  contact 


MBLT 


(3,5,8) 


Segment  and  ellipsoid  identification  numbers 
for  each  belt-segment  contact 


MS  EG 

(3.5,30) 

Segment  and  ellipsoid  identification  numbers 

for  each  segment-segment  contact 

MB  AG 

(3,10,6) 

Segment  and  ellipsoid  identification  numbers 
for  each  airbag-segment  contact  (Cards  F.4) 

NTPL 

(5,30) 

Index  to  NTAB  array  for  each  plane-segment 

contact 

NTBLT 

(5,8) 

Index  to  NTAB  array  for  each  belt-segment 

contact 

NTSEG 

(5,30) 

Index  to  NTAB  array  for  each  segment-segment 

contact 

COMMON 

/RSAVE/ 

XSG 

(3,20,3) 

Points  in  loc.«l  segment  reference  for  first 
three  types  of  time  history  output 

(Cards  H.1-H.3) 

DPMI 

(3,3,30) 

Direction  cosine  matrix  of  principal  moment 

of  inertia  to  local  geometric  reference 

coordinate  system  for  each  segment 

LPMI 

(30) 

Indicator  that  local  geometric  does  not 
correspond  to  principal  moment  of  inertia 

reference  coordinate  system  for  each  segment 

(Cards  B.2.11) 

NSG 

(9) 

Number  of  segments  for  each  type  of  time 

history  output  (Max*20)  (Cards  H.1-H.9) 


MSG 

(20,9) 

The  segment  identification  numbers  for  each 
type  of  time  history  output  (Cards  H.1-H.9) 

MCG 

Number  of  bodies  for  body  property  time 
history  output  (Max-5)  (Cards  H.10) 

MCG1N 

(24,5) 

Body  characteristics  for  body  property  time 
history  output  (Cards  H.10) 

KREF 

(20,9) 

The  reference  segment  numbers  for  each  time 
history  output  (Cards  H.1-H.9) 

COMMON 

/  SGMNTS/ 

D 

(3,3,30) 

Segment  direction  cosine  matrix 

WMEG 

(3,30) 

Segment  angular  velocity  in  local  reference 

WMEGD 

(3,30) 

Segment  angular  acceleration  in  local 

reference 

U1 

(3,30) 

Total  external  forces  on  each  segment 

U2 

(3,30) 

Total  external  torques  on  each  segment 

SEGLP 

(3,30) 

Segment  c.g.  linear  position  in  inertial 

reference 

SEGLV 


(3,30) 


Segment  c.g.  linear  velocity  in  inertial 
reference 


SEGLA 

(3,30) 

Segment  c.g.  linear  acceleration  in  inertial 

reference 

NSYM 

(30) 

Indicators  that  control  the  symmetry  options 
for  body  segments  (Cards  D.7) 

COMMON 

/TABLES/ 

MXNTI 

Dimension  (50)  of  NTI  array 

MXNTB 

Number  of  elements  in  the  NTAB  array 

MXXBl 

Number  of  elements  in  TAB  array  used 

to  define  functions 

MXTB2 

Total  number  of  elements  in  TAB  array 

(SO)  Index  pointers  to  the  TAB  array  for  data 

defining  function  no.  I. 

(1250)  Index  pointers  to  TAB  array  for  each 

function  used  for  allowed  contacts 

(4500)  Subdivided  into  arrays  containing  function 

definitions  and  update  information  for  each 
allowed  contact 


COMMON  /TEMPViy 


CREST 


Coefficient  of  restitution  for  current  impulse 


TTI 


(3) 


Value  of  U1  array  for  impulse 


.*v 

$s 

vv 


Value  of  RK1  for  current  constraint  or  impulse 


Value  of  HK2  for  current  constraint  or  impulse 


JSTOP  (4,2,30)  Indicators  to  signify  joint  is  in  joint  stop 


COMMON  /TEMPVS/ 


Variables  is  this  labeled  common  block  are  temporary  for  each  subroutine 
that  refers  to  it. 


COMMON  /TITLES/ 


(3)  Date  of  computer  run  in  12  alphanumeric 

characters  (Card  A.l.a) 


COMENT 


160  character  description  of  the  run 
(Cards  A.l.b-  A.l.c) 


VPSTTL 


80  character  description  of  the  crash 
vehicle  deceleration  (Card  C.l) 


iiDYTTL 


20  character  description  of  the  crash 
victim  (Card  B.l) 


BLTTTL  (3,8)  20  character  description  of  each  belt 

(Cards  D.3) 


PLTTL 


(5,30) 


20  character  description  of  each  plane 
(Cards  D.2) 


BAG  TIL 


(5,6) 


20  character  description  of  each  airbag 
(Cards  D.4) 


SEG 

(30) 

4  character 

segment  nomenclature  (Cards  B.2) 

JOINT 

(30) 

4  character 

joint  nomenclature 

(Cards  B.3) 

CGS 

(30) 

1  character 

plot  symbol  of  the 

segment  C.G. 

(Cards  B.2) 

JS 

(30) 

1  character 

plot  symbol  of  the 

ioint  location 

(Cards  B.3) 

COMMON  /VPOSTN/ 


ZPLT 


(3)  Printer  plot  coordinates  of  the  vehicle 
reference  origin  (Card  G.l.a) 


SPLT 


AXV 


VTO 


VDT 


(3)  Scale  factors  for  the  printer  plot  axes 
(Card  G.l.b) 


(3,6) 


VAXAB  (6,501,6) 


(6) 


(6) 


Unit  vector  of  deceleration  impulse 
direction 

Tables  of  computed  or  supplied  (Cards  C.3 
or  C.4)  values  of  linear  (1-3)  and  angular 
accelerations  (4-6)  of  vehicle  motion 


Beginning  time  point 
input  (Card  C.2) 


he  deceleration  table 


Fixed  time  interval  for  deceleration  table 
input  (Card  C.2) 


TLMEV 

(6) 

Time  duration  of  the  deceleration  impulse 

(Card  C.2) 

OMEGAV 

(6) 

Frequency  of  the  half-sine  wave  deceleration 
type  (Card  C.2) 

NVTAB 

(6) 

Number  of  points  in  deceleration  table. 

Sign  determines  type  (Card  C.2) 

INDXV 

(6) 

Segment  identification  number  for  each 
specified  motion  definition  (MSBG  on  Card 

C.2. a  or  NVHEL) 

COMMON 

/H1NOFR/ 

WTIME 

(30) 

Initial  time  that  segment  penetrates  wind 

QFU 

(3,5) 

Unit  vector  for  force  application 

QFV 

(3,5) 

Vector  for  torque  application 

WF 

(3,30) 

Wind  force  vectors  applied  to  segments  (local) 

IWIND 

(30) 

Indicator  that  wind  has  been  penetrated 

MiSEG 

(7,30) 

Identification  numbers  for  the  application 
of  wind  forces  on  each  segment  (Cards  F.7) 

NFVSEG 


(6) 


Segment  identification  mmber  for  each  force 
function  (Cards  D.9) 


NFVNT 


(5) 


Function  identification  number  for  each  force 
function  (Cards  D. 9) 


MCfWSEG  (30,30)  Contact  ellipsoid  numbers  and  segment 

identification  numbers  of  blocking  segments 
(Cards  F.7) 
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3.0  CROSS  REFERENCE  CHARTS 
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The  first  two  cross  reference  charts  list  the  COMMON  blocks  used  by  each 
subroutine.  The  remaining  ten  charts  list  the  subroutines  called  by 
each  subroutine. 


KS 

: 

4 

tJ 

'8 

I? 

p 

% 

CL 


1 


•m 


m 


m 


,«»v 

•Mft 

ii 

& 

$ 

1 


c 


i 

I 


( 


« 


l?« 


UJ  I 

gg 


i'iV 


X  [O  b)  t<  O 

a  a  eh  d  «  cq 

x  h  2  a.  a  H 

a  »h  o  o  co  m 

a  w  a  «  o  a 

a  w  p  m  a  o 

a  a  a  j  <  a 

a  a  w  j  e-i 


©  j  o  a  <  j 
i*.  co  £  co  o  J 

U,  «  O  P  (X.  J 

u«  a  e-  w  a  a 
a  j  a  to  w  © 

[1,  h  2  x  3  H 


(1.  O  H  2  H  H 


U>C JhA 

w  &  j  a  <  p 

HJAmJA 
W  J  Eh  m  S  W 

w  j  o  a  © 
w  a  o  n  a  e-> 
w  a  :=>  a  o  eh 
w  q  w  a  e-<  a 


SB  co  o  j 

W  Eh  O 
W  Eh  p 
H  a  Eh 

o  i*  a  a 
o  o  a  < 

©  h  -3  a 
Eh  Eh  to  tO 
Eh  Eh  tO  — 
Eh  tO  IO 
Eh  (O  -* 
a  Eh 

a  a  n  a 


p  <  a  a  io  io 
o  <  a  x  nr  ■<»< 
p  <  d  a  to  to 
p  «a  a  a  to  <n 

ocaaioH 

p  <  a  a  in  cn 

p  <  a  a  h  in 

q  <  a  a  -<  — 

p  <  a  a 


OKOMW 
O  O  a  Eh  O  Eh 

o  z  a  a  eh  w 
o  h  a  a  a  eh 
o  a  <  n  a 
o  a  <  O  Eh  Eh 


a  j  a  p  eh  < 
cq  n  a  a  a  eh 
moo 

ffl  W  J  Eh  «  Eh 
CQ  U  J  Eh  © 


<  »-<  a  m  ©  © 

<  i-h  «  CQ  ©  tO 

<  *-<  n  m  ©  •-H 

<  n  a  cq  <  © 

<  p  a  a  w  eh 
*  <  h  a  < 


*  * 
* 

* 

* 

* 

4<  4i 
4C 
41 

*  * 


in  N  4*  O  ICO 

^H  N  -H 


<  a  a  co  a 

EH  Eh  W  «  EH  « 

<  a  j  eh  a  to 
p  h  a  <5  co  eh 
m  p  hi  s  a  a 
<00000 


<0  r-  o>  in  f-  to 
in  -1  to 


a  j  eh  <  a  a 
m  a  a  eh  a  a 
<  h  a  <  a  o 

Sb  a  Eh  P  SB  CO 
o  o  co  a  <  a 
o  o  o  o  p  p 


a>  ao  to  <0  in  to 


W  CO  CO  Eh  N 
J  W  CO  CO  Eh  U 

n  o  w  w  a  > 
a  a  a  eh  <  < 
j  o  a  a  m  co 
a  a  m  n  a  a 


«  4  4t  4E 


in  in  f-  c-  t-  in 
Ht*  m  in  -h 


co  co  h  co  co  a 

Eh  u  >  >  W  Eh 


a  p  a  a  to 
SB  m  Se  SI  eh  o 


©  <  m  w  n  a 

CO  Eh  Eh  Eh  Eh  > 


o  <  j  j  w  p  oossBoa  mpooaco 


<  PS  X  C OH, 

Eh  Eh  W  PS  Eh  PS 

<  SB  J  Eh  SB  W 

OhD<MH 
m  Q  W  2  SB  SB 
<00000 


1  M  css  St  Eh  U  PS 

I  <  Eh  PS  <  Pj  O 

1  2  sb  eh  o  2  co 

I  O  O  CO  >H  <  w 

I  000000 


W  CO  CO  EH  N 
►J  W  CO  CO  Eh  W 

%%%£%% 

o  o  «  as  so  co 

tv  u,  a  h  ►o  ps 


GO  CO  h  CO  CO  SB 
Eh  W  >  >  W  Eh 

*  j  g.  P|  j  w 

2  n  2  2  eh  o 

o  <  w  w  m  PL, 
CO  EH  Eh  Eh  Eh  > 


o  <  j  j  w  a  O  O  2  2  O  SB  SB  J  O  O  X  CO 


WINDFR 


fig 

g 

& 

t 

•fj 

$ 

s? 

j 

I 

a 


l 


$ 

JK 

S 

:& 

| 

i 

a 

!«T 


1«5 

I 

r 


SC  CQ  lx)  Eh  O 

SC  CL,  Eh  S3  PC  0) 

SC  H-t  SB  IX,  S3  Eh 

SC  h  O  O  CO  m 

SC  tx]  PC  PC  O  SC 

SC  [x]  Q  h  55  O 

sc  n  tx,  j  <  t* 

SC  CO  W  J  Eh 


O  J  O  IS  <  J 
lx.  to  3E  CO  O  J 
haioofaj 
lx,  SB  Eh  lx)  PC  (X, 
tx,  J  !X  to  w  o 
tx,  t-H  SB  Ot,  S3  Eh 

lx,  Q  H  2  H  f, 


tx]  >  <  J  lx,  Q 
W  D  J  K  <  Q 
W  Or  S3  *-<  J  0J 
W  J  H  h  S  W 
W  J  o  SB  © 
txj  *-j  O  M  SC  Eh 
tx)  tx,  S3  SC  O  Eh 
tx]  Q  tx]  0,  £h  SC 


Q  CO  tx] 
Q  CO  lx] 

O  «  H 

Q  PC  o 

a  «  o 

OKCJ 
Q  O  Eh 
O  O  Eh 
Q  O  Eh 
a  O  Eh 

a  h  s; 
a  sc  sc 


mo  j 
Eh  Or 
Eh  Q 
tx.  Eh 

Sh  a,  os 

O'  S3  < 
M  ^  X 

Eh  to  to 

Eh  tO 

to  to 
tO  'H 
Eh 

CL,  M  SB 


Q<S>Xtnto 
Q  <  S3  SC 

Q  C  S3  X  tO  tO 

O  <  D  X  to  M 

Q  4  S)  X  to  "H 

QCDXNN 
QOXh« 
Q  <8*  S3  tX  -H  -H 

Q  <  S3  tX 


U  PC  O  CQ  CQ 
O  o  55  Eh  O  Eh 
O  35  <X,  S3  Eh  tx] 
OHS5ft.DE 
O  SC  <  *-•  SB 
OU.XOEE 


m  J  X  Q  E  X 
CO  HH  SC  tx,  S3  Eh 
03  O  O 

CQ  tx]  J  Eh  «  Eh 
CO  lx]  J  Eh  CD 


X  h  tt;  n  o  Q 

<C  *-<  CC  to  o  to 

X  h  (C  (B  O  h 

X  h  ftj  cq  X  D 
<  a  "3  S3  CO  Eh 

as  «x  hh  ss  < 


1 

*  * 

1 

* 

1 

H  H  H  Cl 

1 

r-H  r-H 

H  H  H 

1 

to  to  H  H  H  00 

1 

1 

1 

1 

OJ 

Eh  O  hH  (0  0 

1 

1 

Eh 

Eh  < 

1 

1 

Eh  Eh  tx]  Eh 

xnxooo 

1 

0  PC 

S>  Eh 

1 

Eh  %  S3  Eh  O  CQ 

sc  S3  n  ta  cc  m 

1 

Eh  Eh 

0,  Q 

1 

O  M  IX,  {D  £h  CO 

►h  *o  pc  pc  ps  cc 

1 

h3  J 

0  SB  * 

1 

<  «C  SB  &  SB  O 

<  Q  tH  M  M  M 

1 

W  tx] 

Oh  J 

1 

tx,  a  m  2  o  os 

*  «c  <  <  <  < 

1 

CC  CQ  PC  CQ  to 

1 

o  o  o  o  o  o 

*  * 


******** 


HctdHctioxifl 

HHMtototoxin 

XJ>JtX!XtXtX>JtXtX 

S3DODS3tDC3DS3 

QQQQQQQQQ 


O  X  J  J  W  O  WSMH«ODEhS5WM 


a 

r 

i 


t$ 

>;w 

*8* 


i 


a 


i 


KWblhO 
3!  ft.  Eh  CD  OJ  P5 

a  >-H  a  Oh  O  H 

SC  i-i  O  O  M  H 
a  w  a  a  o  a 
a  w  o  *-•  a  o 

aotiC<>i 

a  m  w  J  E-< 


o  j  o  a  <  j 
u,  co  z  co  o  J 

lJ.KOQtL.iJ 

u.  a  e-«  m  a  a, 

li.  J  X  W  W  O 
u.  m  a  tv.  a  E-t 

K  Q  h  2  h  h 


W  >  <  J  lx.  Q 

w  a  j  a  <  a 
u  o  a  t-H  j  a 
M  J  H  M  2  w 
ItlJOSO 
ixi  a  o  w  *  e* 
w  u,  a  a  o  h 
UQUKha 


a  <  a  x  to  to 
a  «;  a  x  ■»  •** 


Q  <  a  X  n  n 
QOXwm 


QOKiOh 

q  <  a  x  m  m 


q  <  a  x  h  pi 
Q  <  a  X  r-i 


a  <  a  x 


o  a  o  co  co 

o  o  a  §-<  o  h 

o  S  a  a  e-.  id 

o  M  a  a  a  t* 

o  a  <  *-t  a 

O  b.  «<  O  Eh  h 


m  j  a  a  h  < 
m  n  a  a  a  e- 
m  o  o 

ffl  W  J  Eh  PS  h 

a  M  J  Eh  o 


««H«aoci 

<H«aon 

<  H  (U  (DU  H 

<  hh  as  n  <  o 

<  a  a  a  to  E-r 

3E  <  i-t  a  hj« 


*  *  *  * 


HilO’HOIC<H(o 
fO  — i 


a  to  a  <  a  j 

*-•  -rtototoaaaEHQoro 

p<EHnnEHEHHO>i|i,EHEHn 

3*l;!r!rS:a539MWW*®H 

aHOOOO«PS«KWWMN 

QQQQQQQQOQQOQQ 


hH  N  ©  »H  O  hH 


StHfH  M  n  Q  a 
HpSOIJ^k, 
Pi^hSChhii;  J 
WSOOEhPJ^ 
Oh.04.JOE)> 
MMUMMHUM 


CtHHrtM^N 


EhEhOK  J  J  J 

HawfiKo^ 
a  a  co  u  a  w  a 
Haxf-pio 
o  h  4  a  h  n  4 

h.  h.  >  h.  b.  h.  O 


o  <  a  j  w  a  co  a  m  «  o  a  h  *-•  a  w  co 


■■ 


M 

k 

k 


'!*' 

1 


s 

/ 

«;*5 

i 

0 

$ 


*53 
S 

r 

£ 


$ 

''a' 


a 


SWWHO 
X  h  5  K  n 
*H*Pk!3EH 
X  H  O  O  M  H 

®  w  «  «  o  ss 

33  W  Q  h  35  O 

®  (U  W  J  Eh 


0  J  O  CQ  <  J 

I),  n  S  n  o  J 

U.  «  O  Q  l*.  J 

U,  35  Eh  W  «  Pu, 

U.  J  X  W  W  O 
U,  *-H  5a  Ck  »  Eh 
b.  Q  h  2  H  £h 


MX  JhQ 
li)  D  J  K  <<  Q 
WODhJO 
IDhIEhhSu 
W  J  O  55  O 
U^OhSSEh 
W  lx,  53  35  O  Eh 
U  Q  U  Oh  Eh  a 


Q  <  D  X  E  ID 
OOX^O1 
QOMniO 
a  <  D  X  n  <n 

q  <  D  X  n  h 

Q  <  D  X  <N  CN 

Q  <  S  X  -h  <N 

Q  <  D  X  ->  -< 

Q  <  D  X 


ClMOWW 
O  O  S!  Eh  O  Eh 
USMXHU 
U  H  a  e,  D  El 

o  a:  <  n  sa 

O  l*.  <  O  Eh  Eh 


OQ  J  X  a  Eh  «*! 
CQ  •-<  35  Ph  53  Eh 
CD  CJ  O 

ffl  W  J  Eh  W  E* 
fflW  JEO 


<hpsooio 
<(  h  K  ffl  O  'H 
<q  m  ps  m  <  o 

<  a  -J  D  W  EH 

5E  <!  t-H  35  < 


>>  O  35  W  6h  m 
Eh«<550OTDPS0 
JJhMCJMSE 
w^opsoaEw 

BBIWMhhMII 

sasaxaaa 


|i,OXQE35HKXWa<JJX3 

oao<COOHp,d<E<b]UO<0)b. 

XXXXXXXXXSBBXS8X 


o  <  j  j  w  a  naoaoDEHaun 


I MPLS 2 
IMPULS 
INITAL 
INTERS 


m 

Mm 


m 

v!*> 


a 

il* 


a 


ft 

*» 


«!« 


c 


tjjfl 

S 


ss 

3 

t.*U 

4 

g 


32  CO  lx)  H  O 

X  di  H  D  K  B 

X  H  Z  di  |3  f 

33  O  O  W  M 

33  U3  «  «  O  X 

ZUIQHZO 
32  CQ  Pl,  _}  <!  >-• 

X  ID  Id  J  h 


0  J  O  03  <  J 
it  iaSiao  J 
U.  «  O  Q  U.  J 
U,  55  U  «  ft. 
U.  J  X  W  txj  O 
U.  *-1  SB  0*  »  E-* 

lx.  Q  H  2  W  fn 


Q<3Xinit) 
Q  <  D  X  ^  ^ 
q  <  3  X  n  n 
QOXnw 
QOXn^ 

Q  <  3>  X  CN  CM 

Q  <  S  X  h  c) 

Q  <  D  X  -h  —• 

Q  <  Z>  X 


O  ID  O  ID  10 
OOXhOh 
o  I  0.  3  h  W 
CJHZBSh 

a  x  <  >->  sb 

o  u,  <  a  h  h 


03  j  x  a  h  < 

BhZBDH 

aoo 

n  UJ  H  B  H 
ffl  W  J  £h  O 


<  >-*  K  CQ  O  0 

<H«oqn 

<  h  «  m  g  rt 

<:  -<  k  at  <  0 

<  q  ^  d  w  e-< 

i  <  «  2  < 


E-i  W  W 
3>  X  X  w 
3.  i  <  £ 
3  X  O  h 

h  h  O  h 
X  J  J  J 


*  *  * 
* 

* 


«  N  H  o 
lO  — • 


Eh 

-h  to  o  s 
to  to  a:  o< 
Eh  E-i  H  H 

sags 


EEEEEEEE 
DFJLLQUV 
EU00TULA 
PNINI IRL 
TCNGMLAF 
HTT  EBDD 

1 

1 

1  * 

*  I 

1 

1  * 

1 

1  * 

1 

1 

*  1 

1 

1 

1 

1 

1 

* 

* 

1 

1 

1 

1 

1 

1 

1 

I 

* 

1 

1 

1 

1 

1 

1 

1 

i 

Q  N  pu,  1 

\ 

1 

1 

1 

Q  10  2  10  O  J  1 

1 

1 

I 

1 

a  CO  W  Eh  O'  1 

1 

1 

1 

1 

Q  W  W  Eh  Q  1 

1 

1 

1 

1 

Q«HfcH  1 

1  * 

1 

1 

1 

Q  «  O  tH  Oh  0«  1 

1 

1 

1 

* 

1 

OKOOD'D  t 

1 

1 

1 

1 

a  «  0  m  <->  x  1 

1  * 

1 

1 

1 

Q  O  Eh  Eh  to  to  1 

1 

1 

1 

1 

Q  O  Eh  Eh  to  —  1 

1 

1 

1 

1 

Q  O  Eh  to  to  1 

1 

1 

1 

1 

Q  O  Eh  to  -H  1 

1 

1 

1 

1 

Q  H  58  Eh  1 

1 

*  | 

* 

1  * 

1 

Q  X  X  B  h  Z  1 

1 

1 

1 

t 

ci«Hnrt«HHeH 


h.  N  OS  Eh 
W  &  \  J  W  M  X  Eh  X  Oh 

24.JUK(llhl»HH 

Ol.OhOhOhO.Ol.OhO)O.Oi 


H  H  H  Cl  H  H 


U  Eh 

t*  « 

H  H  Eh  <4 

U  <  M  H  tH  H 

Oft  &  O  O  O  Oft 

O'  O'  Oft  04  «  OS 


0<J  JUQ  W  D  CQ  «  O  D  H  m  a  H  W 


3 

SB 

F 

'ijsa 
& 

u 


& 

•iW 

i 


a 


5® 


>-.  a,  «  Q  w  O 

>3  Q  >h 
3  >-h  2  Q  >* 


>  I HMfcK 

>  *-i  CO  O  O  CO 

>uxa.oto 


ShQlitQO 
ID  O  <  H  W 

3  2  h  H  H 

H  03  h-t  O  U.  CO 


CO  Oh  J 
CO  Oh  Q 
MO  J 
WO  J 

CO  J  0< 

CO  h  SB 
CO  W  Eh 
CO  W  Eh 

m  wo 

co  w  < 


H  2  111 
<3  X  Oh 

>  03 

>  < 

JOH 

Oh  3  Eh 
33  Oh  <N 
33  Oh  'H 

co  w  o 

03  O  35 


03  CO  H  <JJ  03  Eh 
03  O  Eh  <  Eh  01 
03Oh 
03  O  05  Eh 
Ot  33  <  Eh 

at  co  w  eh 


w  Oh  hJ  £h 
ft  2  H 

CO  Eh  Oh  03 
HKO-N 
CO  W  CD  b, 
03  W  «C 
W  J  Oh 

woo 

«B  33  X 
2  Id  J 


tH  Oh  D  Eh 

Eh  33  O 
Eh  to  to 
Eh  tO  <—> 


JEhhSU 

J  O  U  <3  X  co 
J  H  2  «S  5*3  CO 
^  h  S;  Oh  33  h 


<  h  2  E  W  05  CO 

ol  H  2  HH  Eh  <  J 

h  g  Cl,  33  J  M 
H  is  Oh  J  CO  CN 


>  U.  2 

>  CQ  2 
><J 
CO  O  J 
03  01  < 
O.  W  2 
2  Eh  03 
►J  Oh  2 
JOhK 
J  w  2 
U.  O  2 
W  CO  Eh 
Q  <3  a 
£0  O  3*3 
M2Q 
<C  «  0. 


*  *  HE 


*  *  * 


*  *  ik 


HH<fOH0)NHOHH-H 

to  ft 


2  —*  to  2  <  03  i-3 

ft  HtoiOtOOSBiEflOO 
OjEtOiOEEnHOOiWEiEiM 
K2EEEEOOOhWW*Oh 
2h000003030303COCOCON 

qqqqqqqqoqqqqq 


hc1I11hOhh(» 


x  eh  eh  m  co  a  a 

EhU20Sh3  43(x. 
0h2h2hh05J 
W33DOEh33J< 
0  11,03  J93>> 
MHHHH WWW 


N  H  H  H  MM  w 


Eh  Eh  ©  Oh  J  J  J 

h  |3  b)  pi  W  o  4 

2  Oh  CO  01  Q  SO  OQ 

h  2  X  E  O  *  O 

Q  I-H  J  2  03  CO  J 

O,  Oh  Oh  Oh  O,  Oh  © 


J4UQ  C0»M03O2Eh*-h2WC0 


9 _ 


INITAL 

INTERS 


QUAT 

RCRT 

ROT 

ROTATE 

RSTART 


$ 

hJJ» 


CO 

(1] 

2 

t-1 

Eh 

CD 

O 

05 

m 

cd 

to 

CD 

►-H 

J 

J 

< 

O 


>h  0,  05  Q  ID  CD 
XQN 
*  •-<  S5  Q  >" 


>  m  co  a,  os 

>  H  W  O  O  CO 

>  hh  SB  0<  D  Eh 

>  id  sc  a.  o  co 


cd  ph  a  fa.  a  a 
cd  ph  a  <  Eh  id 
D  55  h  H  H 
Eh  05  H  CD  b.  CO 


co  a, 
co  ph 


o 

o 

j 


co 
co 
co 
co 
co  id 
to  id 

CO  ID 
CO  ID 


J  HH 

a  < 

j  > 
j  > 
Oh  J 
2  PH 

Eh  CD 
Eh  CD 
CD  CO 
<  05 


IS 

05 

< 

O  Eh 
CD  Eh 
O.  <N 
Oh 

ID  CD 
O  X 


05  CO  Eh  <  05 
05  O  Eh  <  Eh 
05  O  Eh 
05  O  05  Eh 
O'  O  <C  Eh 

O'  CO  ID  Eh 


HPk  J 
H  2  Eh 
CO  Eh  PH 
Eh  >5  >h 
CO  ID  CD 
05  ID  <C 
ID  J  PH 
ID  Q  CD 
<  CD  >5 
2  ID  J 


05 

N 

lx. 


o  CD  Eh  Ph  CD  Eh 
O  05  Eh  W  O 

s  <  Eh  to  m 

S  <  Eh  n  -H 


J  Eh  H  3E  ID 
JOOCXco 

JH2««XI0 

SCHSCIHDH 


m  2  E*  ID  05  CO 
H  2  H  E  <  J 
H  5§  CH  CD  J  CO 
H  2  ft,  J  cn  o 


YPRDEQ 


4.0  LIST  OF  130  SUBROUTINES 
THAT  COMPRISE  THE  ATB-IV  MODEL  COMPUTER  PROGRAM 

The  first  subroutine  is  a  list  of  the  common  blocks  used  by  the  program, 
the  second  is  the  main  program  followed  by  all  of  the  remaining 
subroutines  in  alphabetical  order.  Each  subroutine  name  is  appended 
with  its  revision  number  followed  by  the  date  of  the  latest  change  to 
the  subroutine.  This  same  data  and  revision  number  appears  on  the 
second  line  of  each  subroutine  in  Section  5. 


SUBPROGRAM 
&  REV.  NO. 


DATE 


SUBPROGRAM 
&  REV.  NO. 


DATE 


BDATA 

IV 

07/23/86 

MAIN 

IV 

07/23/86 

ADJUST 

IV 

07/23/86 

AIRBAG 

IV 

07/24/86 

AIRBGG 

III 

.5 

10/17/85 

AIRBG1 

IV 

07/24/86 

AIRBG3 

IV 

07/23/86 

BELTG 

IV 

07/23/86 

BELTRT 

IV 

07/23/86 

BGG 

IV 

07/23/86 

B INPUT 

IV 

07/24/86 

BLKDTA 

IV 

07/23/86 

CFACTT 

3 

05/31/73 

CHAIN 

IV 

07/24/86 

C INPUT 

III 

.  2 

08/08/84 

CMPUTE 

III  .2 

08/08/84 

CONTCT 

III 

.2 

08/08/84 

CROSS 

3 

05/31/73 

DAUX 

IV 

07/24/86 

DAUX 11 

IV 

07/24/86 

DAUX12 

IV 

07/24/86 

DAUX22 

IV 

07/24/86 

DAUX31 

IV 

07/24/86 

DAUX32 

IV 

07/24/86 

DAUX33 

IV 

07/24/86 

DAUX44 

IV 

07/24/86 

DAUX55 

IV 

07/24/86 

DHHPIN 

IV 

07/24/86 

DINT 

IV 

07/23/86 

D0TT31 

17 

12/20/76 

DOTT33 

17 

01/03/77 

D0T31 

17 

01/03/77 

DOT33 

17 

01/03/77 

DRCIJK 

18 

02/24/78 

DRCQUA 

III 

.  5 

07/31/85 

DRCYPR 

IV 

07/23/86 

DRIFT 

IV 

07/24/86 

DSETD 

IV 

07/23/86 

DSETQ 

IV 

07/23/86 

DSMSOL 

3 

07/08/74 

DZP 

IV 

07/23/86 

EDEPTH 

IV 

07/23/86 

EFUNCT 

20 

04/29/80 

EJOINT 

IV 

07/24/86 

ELONG 

1 

10/05/72 

ELTIME 

III  .2 

08/08/84 

EQUILB 

IV 

02/01/88 

EULRAD 

IV 

07/23/86 

EVALFD 

IV 

07/23/86 

FDINIT 

III. 2 

08/08/84 

F INPUT 

IV 

02/01/88 

FLXSEG 

IV 

07/23/86 

FNTERP 

IV 

04/10/87 

FRCDFL 

III  .2 

08/08/84 

FSMSOL 

III 

.  2 

08/08/84 

GLOBAL 

IV 

07/24/86 

HBELT 

IV 

02/01/88 

HBPLAY 

III  .5 

10/17/85 

HEDING 

IV 

02/01/88 

HERRON 

IV 

07/23/86 

HICCSI 

IV 

10/08/87 

HINPUT 

IV 

07/23/86 

HPTURB 

IV 

07/23/86 

HSETC 

III .  2 

08/08/84 

HYABF 

IV 

02/07/87 

HYBND 

IV 

02/07/87 

HYBOX 

IV 

02/07/87 

HYDAD 

IV 

02/07/87 

HYEST 

IV 

02/07/87 

HYFCN 

IV 

02/07/87 

HYLIM 

IV 

12/11/87 

HYLPR 

IV 

02/07/87 

HYLPX 

IV 

02/07/87 

HYNTR 

IV 

02/07/87 

HYPEN 

IV 

02/07/87 

HYREA 

IV 

12/11/87 

HYSOL 

IV 

02/01/88 

HYVAL 

IV 

12/11/87 

HYVBX 

IV 

02/07/87 

HYVFN 

IV 

12/11/87 

IMPLS2 

IV 

07/24/86 

IMPULS 

IV 

07/24/86 

INITIAL 

IV 

07/24/86 

INTERS 

IV 

02/23/86 

K INPUT 

IV 

07/23/86 

LINAXS 

18 

02/28/78 

ravnBnRmmwwmvmnmnvTie!  vjmuiiu  wiiuipvuuiivy 


SUBPROGRAM  SUBPROGRAM 


&  REV  NO. 

DATE 

&  REV  NO. 

DATE 

LOGAXS 

19 

09/18/79 

LTIME 

III  .2 

08/08/84 

MAT31 

17 

01/03/77 

MAT33 

17 

01/03/77 

ORTHO 

3 

05/31/73 

OUTPUT 

IV 

02/01/88 

PANEL 

III  .  2 

08/08/84 

PDAUX 

IV 

07/24/86 

PLEDG 

IV 

02/07/87 

PLELP 

IV 

02/07/87 

PLREA 

IV 

12/11/87 

PLSEGF 

III  .5 

09/03/85 

PLTXYZ 

III  .  5 

05/30/85 

POSTPR 

IV 

02/01/88 

PRINT 

IV 

07/24/86 

PRIPLT 

IV 

07/24/86 

QSET 

III  .3 

10/01/84 

QUAT 

IV 

07/23/86 

RCRT 

3 

07/19/73 

ROT 

IV 

07/23/86 

ROTATE 

IV 

02/20/87 

RSTART 

IV 

07/24/86 

SEARCH 

IV 

07/24/86 

SEGSEG 

IV 

02/07/87 

SETUP  1 

IV 

07/24/86 

SETUP2 

IV 

07/24/86 

S INPUT 

IV 

02/20/87 

SLPLOT 

III. 2 

08/08/84 

SOLVA 

III  .  2 

08/08/84 

SOLVR 

III. 2 

08/08/84 

SPDAMP 

IV 

07/24/86 

SPLINE 

19 

05/14/79 

SPRNGF 

IV 

07/23/86 

TRIGFS 

19 

08/05/78 

UNIT  1 

IV 

02/20/87 

UPDATE 

IV 

07/24/86 

UPDFDC 

III  .2 

08/08/84 

VEHPOS 

IV 

07/23/86 

VINPUT 

IV 

07/24/86 

VISCOS 

19 

10/23/78 

VISPR 

IV 

02/01/88 

WINDY 

IV 

07/23/86 

XDY 

IV 

07/23/86 

YPRDEG 

IV 

11/26/86 

» 


5.0  FORTRAN  SOURCE  CODE  OF 
TH*.  ATB-IV.O  PROGRAM 


Each  of  the  130  ATB-1V  subroutines  are  listed  in  this  section.  The 
second  line  of  each  subroutine  contains  the  subroutine  revision  number 
and  the  date  of  the  latest  change  to  the  subroutine.  Columns  72-80  of 
each  line  contain  the  subroutine  name  unless  the  line  is  a  new  or 
changed  line  from  the  listing  in  Ref.  4.  In  these  cases  the  name  of  the 
latest  change  is  in  columns  72-80.  The  first  subroutine  is  the 
BLOCKDATA  containing  the  COMMON  blocks  used  by  the  program.  The  second 
routine  is  the  MAIN  program  which  controls  the  flow  of  the  program.  The 
remaining  subroutines  are  listed  alphabetically. 


BLOCK  DATA 


DECKA 

C  REV  IV  07/23/86TW0PI 

IMPLICIT  REAL*8  (A-H.O-Z)  DECKA 

COMMON/COMTRL/  TIME, NSEG , NJNT , NPL , MBLT , NBAG , NVEH , NGRHD ,  DECKA 

*  NS , NQ , NSD , NFLX , NHRNSS , NWI NDF , N  JNTF , NPRT ( 36 ) , MPQ  PAGE 

COMMOM/CNSMTS/  PI .RADIAN ,Q, THIRD , EPS (24) ,  DECKA 

»  DNITL,UNITM,DNITT,GRAVTY(3) ,TWOPI  TWOPI 

COMMON/ JBARTZ/  MMPL(  30) ,MNBLT(  8) ,MMSEG(  30) ,MNBAG(  6) ,  DECKA 

*  MPL(3 ,5 ,30) ,MBLT (3 ,5,8) ,MSEG(3 ,5 ,30) , MB AG (3 ,10,6) ,  DECKA 

*  MTPL(  5 ,30) ,NTBLT(  5,8),NTSEG(  5,30)  DECKA 

COMMON/TITLES/  DATE (3) ,C0MENT(40) ,VPSTTL(20) ,BDYTTL(5) ,  DECKA 

*  BLTTTLI5 ,8) ,PLTTL(5,30) ,BAGTTL(5 ,6) ,SEG(30) ,  DECKA 

«  JOINT(30) ,CGS(30) ,JS(30)  DECKA 

BEAL  DATE , COMEMT , VPSTTL , BDYTTL , BLTTTL , PLTTL , BAGTTL , SEG , JOINT  DECKA 

LOGICAL* 1  CGS.JS  DECKA 

COMMON/FORCES/PSF (7 , 70) ,BSF(4,20) ,SSF(10,40) ,BAGSF(3,20) ,  NCFORC 

«  PRJNT (7,30), NPANEL ( 5 ) , NPSF , NBSF . NSSF . NBGSF  DECKA 

COMMON/RSAVE/  XSG(3 , 20 , 3)  .DPMI (3 , 3, 30) ,LPMI (30) ,  ATBIII 

*  NSG(9) ,MSG(20,9) , MCG , MCGIN (24 , 5) ,KREF(20,9)  TTHKREF 

COMMOH/CDINT/  UU(4) ,GH(3,4) ,  DECKA 

«  E(3,240) ,FF(5,240) ,GG(5,240) ,Y(5,240) ,0(5,240) ,  DECKA 

*  H , HPRINT , TSAVE , TPBINT , TSTART , ICNT , IDBL , IFLAG  DECKA 

COMMON/DAMPER/  APSDM(3,20) ,APSDN(3,20) ,ASD(5,20) ,MSDM(20) ,MSDN( 20) DECKA 
COMMON/HRNESS/  BAR(15, 100) ,BB(100) .BBDOT(IOO) ,PL0SS(2, 100) ,  DECXA 

*  XL0NG(20) ,HTIME(2) ,IBAR(5,100) ,NL(2,100) ,  DECKA 

*  NPTSPB(20) ,NPTPLY(20) ,NTHBNS(20) ,NBLTPH(5)  DECKA 

C  NOTE:  FF  REPLACES  F.  DECKA 

LOGICAL* I  FREE  SLIP 

COMMON/TEMPVS/  JTMPVS (24000) .FREE (30)  SLIP 

COMMON/ SGMNTS/  D(3,3,30) ,WMEG(3,30) ,«MEGD(3,30) ,UI(3,30) ,02(3,30) .DECKA 

*  SEGLP(3,30) ,SEGLV(3,30) ,SEGLA(3,30) ,NSYM(30)  DECKA 

COMMON/DESCRP/  PHI (3,30) ,W(30) ,RW(30) ,SR(4,60) ,HA(3,60) ,HB(3,60) ,  SLIP 

*  RPHI (3,30) ,HT(3 ,3 ,60) .SPRING (5 ,90) ,VISC (7,90) ,  DECKA 

»  JNT(30) ,IPIN(30) ,ISING(30) , IGLOB(30) ,JOINTF(30)  DECKA 

COMMON/CNTSRF/  PL (24 , 30) ,BELT(20 ,8) ,TPTS (0 ,8) ,BD (24 ,40)  EDGE 

COMMON/TABLES/MXNTI .MXNTB .MXTBl ,MXTB2 ,NTI (50) ,NTAB(1250) ,TAB(4500)BUTLER2 
COMMON/ VPOSTN/  ZPLT(3) ,SPLT(3) ,AXV(3,0) ,VATAB(6,501 ,6) ,  VEHICL 

»  VT0(6) ,VDT(6) ,TIMEV(6) ,0MEGV(6) ,NVTAB(6) ,INDXV(6)  DECKA 

COMMON/CMATRX/  VI (3 , 30) ,V2(3,30) ,V3(3,I2) ,B12(3,3,60) ,A22(3,3,0O) .DECKA 

*  F (3 ,30) ,TQ(3 ,30) , WJ (30) , A1 1 (3 ,3 ,30)  SLIP 

COMMON/CEULER/  IEULER(30) ,HIR(3 ,3 ,90) ,ANG(3 ,30) , ANGD(3 ,30) ,  JDBIFT 

*  FE(3,30) ,TQE(3,30) ,CONST(5,30)  JDRIFT 

COMMON/ FLXBLE/  HF (4 , 12 ,8) ,B42 (3 ,3 , 24) ,V4 (3 ,8) ,NFLEX(3 ,8)  DECKA 

COMMON/CSTRNT/  A13(3,3,24) ,A23(3,3,24) ,B3I(3,3,24) ,B32(3,3,24) ,  DECKA 

»  HHT(3,3, 12) ,RK1 (3, 12) ,RK2(3,I2) ,QQ(3,12) ,TQQ(3,12) .DECKA 

*  RQQ(3, 12) ,HQQ(3, 12) ,SQQ(12) ,CFQQ(12) ,  DECKA 

*  KQ1 (12) , KQ2 ( 12) .KQTYPE ( 12)  DECKA 

COMMON/TEMPVI /  CREST ,TTI (3) ,R1 I (3) ,R2I (3) , JST0P(4 ,2 ,30)  DECKA 

COMMON/ INTEST/  SGTEST(3,4,30) ,XTEST(3, 120) ,SEGT(120) ,BEGT(120)  DECKA 

REAL  SEGT  DECKA 
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COMMON/ COMA IN/  VARI240) ,DER(240) ,DT,HO,HMAX,HMIN,RSTIME,  DECKA 

«  ISTEP.NSTEPS ,NDINT,NEQ, IRSIN, IRSOOT  DECKA 

COMMON/ ABDATA/  ZDEP(3,5) ,DBR(3,3,5) ,DPVCTB(3,5) ,DEPLOY(3,5) ,  DECKA 

*  AB(3,5) ,B(9,4,5) ,ZR(3,4,5) ,BFB(3.4,5) ,DRR{0,4,5) .  DECKA 

*  VBACHH5) ,VSCS(5) ,SPEK(5) ,CK(5) ,CMASS(5) ,CYMIN(5) ,  DECKA 

*  CYMOUT(5) ,BAQPV(5) ,PD(5) ,VBAO(5) ,VOLBP(5) ,  DECKA 

»  PCYV(5) ,PCYMIN(5) ,PVBAG(5) ,TV1 (3,4,5) ,TV2(3, 10,5) ,  DECKA 

*  SWITCH (5) ,PYM0UT(5) .SCALE (5) , PBEVT, IFULL(6)  DECKA 

COMMON/CYDATA/  CYTD(5) ,CYPA(5) ,CYSP(5) ,CYT0(5) ,CYV0(5) ,CYCD(5) .  DECKA 

*  CYK(5) ,CYR(5) ,CYAT(5) ,CYPV(5) ,CYCD0(5) ,CYA0(5) ,  DECKA 

«  CYPO (5) , CYSS (5) ,CYLO (5) ,CYC(5) ,CYRH00(5) ,CY¥MAX(5) .DECKA 

«  CY0RFC(5) ,CYRH0(5) ,CYT(5) ,CYP(5) ,CYV(5)  DECKA 

COMMON/ WINDFB/  WTIME (30) ,QF0(3 , 5) ,QFV(3 ,5) , WF (3 ,30) , IWIND(30) ,  WINDOP 

*  MWSEG(7,30) ,NFVSEG(6) ,NFVNT(5) ,M0WSEQ(30 ,30)  WINDOP 

END  DECKA 


MAIN  A 

AAMRL  ABTICULATED  TOTAL  BODY  (ATBIV)  MODEL  COMPUTES  PROGRAM  ATBIV 

DEVELOPED  BY  CALSPAN  COBP.  AND  J&J  TECHNOLOGIES  INC.  BUTLER 1 

BEV  IV  07/23/86TW0PI 

MAIN  PBOGBAM  MAINA 

MAINA 

PERFORMS  CARD  INPUT,  PROGRAM  INITIALIZATION.  MAINA 

CONTROL  OF  INTEGRATION  LOOP  AND  OPTIONAL  OUTPUT.  MAINA 

MAINA 

IMPLICIT  REAL*8 (A-H.O-Z)  MAINA 

COMMON/CONTRL/  TI ME , NSEG , NJNT , NPL , NBLT , NBAG , NVEH , NGRND ,  MAINA 

«  NS , NQ , NSD , NFLX , NHRNSS , NWI NDF , N JNTF , NPRT (36) , NPG  PAGE 

COMMON/TITLES/  DATE(3) ,COMENT(40) ,VPSTTL(20) ,BDYTTL(5) ,  MAINA 

*  BLTTTL(5,8) ,PLTTL(5,30) ,BAGTTL(5,6) ,SEG(30) ,  MAINA 

*  JOINT(30) ,CGS(30) ,JS(30)  MAINA 

REAL  DATE , COMENT , VPSTTL , BDYTTL , BLTTTL , PLTTL , BAGTTL , SEG .JOINT  MAINA 

LOGICAL* 1  CGS.JS  MAINA 

COMMON/ CNSNTS/  PI .RADIAN, G, THIRD, EPS (24) ,  MAINA 

»  UNITL,UNITM,UNITT.GRAVTY(3) .TWOPI  TWOPI 

COMMON/COMAIN/  VAR (240) , DEB (240) , DT,HO,HMAX,HMIN,RSTIME,  MAINA 

«  I STEP , NSTEPS , NDINT , NEQ , IRSIN , IRSOUT  MAINA 

LOGICAL  NPRT 1 , NPRT2 , NPRT 3  MAINA 

CALL  ELTIMEQ.  1)  MAINA 

PECONV 

MAKE  THE  OUTPUT  FILES  PRINTER  CONTROL  FILES  FOR  THE  P&E  PECONV 

PECONV 

CALL  CARC0N(6 , 1)  PECONV 

CALL  CARC0N(2 , 1 )  PECONV 

MAINA 

WRITE  PROLOGUE  ON  PRIMARY  OUTPUT  UNIT.  MAINA 

MAINA 

NPG=2  PAGE 

WRITE (6, 11)  MAINA 

11  FORMAT ( 1H1 ,30X, ’AAMRL  ARTICULATED  TOTAL  BODY  (ATB)  MODEL’, 52X,  ATBIV 

*  ’PAGE  1’////  PAGE 

*  3 IX, 'DEVELOPED  BY  CALSPAN  CORP.,  P.O.  BOX  400,  BUFFALO  NY  14225 ’ /BUTLER1 

*  3 IX, 'AND  BY  J&J  TECHNOLOGIES  INC.,  ORCHARD  PARK,  NY  14127’  //  EDGE 

*  3 IX, 'FOR  THE  AIR  FORCE  ARMSTRONG  AEROSPACE  MEDICAL  RESEARCH  ’  /  VEHICL 

*  3 IX, ’LABORATORY,  WRIGHT  PATTERSON  AIR  FORCE  BASE  ’  /ATBIV 

*  31X, ’UNDER  CONTRACTS  F3361 5-75C-5002 , -78C-0516  AND  -80C-05117’  //BUTLER1 

»  3 1 X , ' AND  FOR  THE  NATIONAL  HIGHWAY  TRAFFIC  SAFETY  ADMINISTRATION, ’BUTLER1 
*/31X,’U.S.  DEPARTMENT  OF  TRANSPORTATION,  UNDER  CONTRACTS’  /  BUTLER 1 


*  31X, ’FH-1 1-7592 ,  HS-053-2-485 ,  HS-6-01300  AND  HS-6-01410.’  ////  BUTLER1 

*  31X, 'PROGRAM  DOCUMENTATION:  NHTSA  REPORT  NOS.  D0T-HS-80 1-507 ’  /  BUTLER 1 

»  31X, ’THROUGH  510  (FORMERLY  CALSPAN  REPORT  NO.  ZQ-5180-L-1) , ’  /  BUTLER 1 
»  3 IX, 'AVAILABLE  FROM  NTIS  (ACCESSION  NOS.  PB-241692,3,4  AND  5),'  / BUTLER 1 
»  3 IX, ’APPENDIXES  A-J  TO  THE  ABOVE  (AVAILABLE  FROM  CALSPAN),’  /  BUTLER 1 
»  3 1 X , ’ AND  REPORT  NOS.  AMRL-TR-75- 14  (NTIS  NO.  AD-A014  816),/  ATBIV 

*  31X, ’AFAMRL-TR-80-14  (NTIS  NO.  AD-A088  029),  AND’/  ATBIV 

*  31X, ’ AFAMRL-TR-83-073  (NTIS  NO.  AD-B079  184).’//// 
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»  3 IX, ’PBOQRAM  ATB-IV,  EXECUTED  ON  THE  AAMRL/BB  CONCURRENT ’ / 

»  31X/3250  COMPUTER,  WRIGHT-PATTERSON  AFB,  OHIO’////) 

INPUT  CARDS  A. 1  AND  A. 2,  TEST  FOR  RESTART. 

CALL  BLXDTA 

READ (5,12)  DATE , I RS I N , I RSOUT , RST I ME , COMENT 

12  FORMAT (3A4 , 214 ,F8 . 0/20A4/20A4) 

WRITE (6. 13)  DATE, IRS IN, I RSOUT, RST I ME, COMENT 

13  FORMAT  (/////4X,  3A4  ,  ’  IRSIN=’,I4,’  IRSOUT=  ’  ,  14  .  ’  RSTIME  =’,F8.4 

*  61X, ’CARDS  A’ //IX, 20A4/1X, 20A4//) 

IF  (IRSIN.NE.O)  GO  TO  18 

INPUT  CARDS  A. 3, A. 4  AND  A. 5. 

READ (5. 14)  UNITL , UNITM, UNITT , GRAVTY , G 

14  FORMAT ( 3 A4 , 4F 1 2 . 0 ) 

IF  (G.EQ.O.O)  G  =  DSQRT (GRAVTY ( 1) «*2+GRAVTY(2) »*2+GRAVTY (3) »«2) 
READ (5,15)  ND I NT , NSTEPS , DT , HO , HMAX , HMI N , NPRT 

15  FORMAT (21 4, 4F8. 0/3612) 

WRI TE ( 6 , 1 6 )  UNI TL , UNI TM , UNI TT , GRAVTY , G , 

«  NDINT, NSTEPS, DT, HO. HMAX, HMIN 

16  FORMAT (5X, 'UNITL  =  ’ ,A4 , 5X, ’ UNITM  =  ’ ,A4 ,5X, ’UNITT  =  \A4, 

*  5X, 'GRAVITY  VECTOR  =  ( * , F9 . 4 , ’ , ’ , F9 . 4 , ’ , ’ , F9 . 4 , ’ ) ’ , 5X , ' G  = 
•F9.4.//.5X, ’NDINT  =’, 14 , 5X. ’ NSTEPS  *’,I5,5X,’DT  *',F8.6, 

*  5X/H0  = ’ .F8.6.5X,  ’HMAX  -  ’  .F8.6.5X,  'HMIN  =’,F8.8) 

WRITE (6 , 17)  (1,1=1,38) , NPRT 

17  FORMAT! ’0  NPRT  ARRAY' /3X.36I3/3X, 3613) 

NPRT4  =  NPRT (4) 

IF(NPRT(26) .GT.6)  STOP  93 
IF  (NPRT (4) .LT.O)  GO  TO  50 

CALL  INPUT  ROUTINES 

CALL  B INPUT 
CALL  V INPUT 
CALL  S INPUT 
CALL  CINPUT 

PROGRAM  INITIALIZATION 

TIME  =  0.0 
CALL  INITAL 
GO  TO  19 

READ  INPUT  DATA  FROM  RESTART  TAPE  AND  WRITE  NEW  TAPE. 

THE  FIVE  FUNCTIONS  OF  SUBROUTINE  RSTART  ARE: 

1.  READ  INPUT  &  INITIALIZATION  RECORD  FROM  OLD  RESTART  TAPE. 

2.  WRITE  INPUT  &  INITIALIZATION  RECORD  ONTO  NEW  RESTART  TAPE. 

3.  READ  TIME  POINT  RECORD  FROM  OLD  RESTART  TAPE. 


ATBIV 
ATBIV 
MAINA 
MAINA 
MAINA 
MAINA 
MAINA 
MAINA 
MAINA 
.MAINA 
MAINA 
MAINA 
MAINA 
MAINA 
MAINA 
MAINA 
MAINA 
MAINA 
MAINA 
MAINA 
CHOI I I 
MAINA 
CHGIII 
’  CHGIII 
MAINA 
MAINA 
MAINA 
MAINA 
MAINA 
TGM0D1 
MAINA 
MAINA 
MAINA 
MAINA 
MAINA 
MAINA 
MAINA 
MAINA 
MAINA 
MAINA 
MAINA 
MAINA 
MAINA 
MAINA 
MAINA 
MAINA 
MAINA 
MAINA 
MAINA 
MAINA 
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4.  READ  NEW  INPUT  DATA  FROM  INPUT  STREAM  FOR  RESTART.  MAINA 

5.  WRITE  TIME  POINT  RECORD  ONTO  NEW  RESTART  TAPE.  MAINA 

MAINA 

18  CALL  RSTART ( 1 , IRSIN)  MAINA 

CALL  RSTART (4 .5)  MAINA 

NPRT4  =  NPRT (4)  MAINA 

Id  IF  ( IRSOUT . NE . 0)  CALL  RSTART (2 . IRSOUT)  MAINA 

MAINA 

INTEGRATION  LOOP  -  ADVANCE  TIME  BY  EITHER  INTEGRATING  THROUGH  MAINA 

SUBROUTINE  DINT  OR  BY  FETCHING  TIME  POINT  RECORD  FROM  RESTART  TAPEMAINA 

MAINA 

TIME  =0.0  MAINA 

I STEP  =0  MAINA 

20  IF  (IRSIN. EQ.O)  GO  TO  23  MAINA 

IF  (TIME. GT.RSTIME+O . 5*DT)  GO  TO  23  MAINA 

IF  (DABS (TIME-RSTIME) . LT.O. 5*DT)  GO  TO  21  MAINA 

CALL  RSTART (3, IRSIN)  MAINA 

GO  TO  24  MAINA 

21  CALL  RSTART (4. 5)  MAINA 

IF  (NPRT(4) .LT.O)  GO  TO  50  MAINA 

23  CALL  DINT  MAINA 

MAINA 

OPTIONAL  OUTPUT  MAINA 

1.  PRINTER  PLOT  ON  OUTPUT  UNIT  2  CONTROLLED  BY  NPRT (5)  &  (6) .  MAINA 

MAINA 

24  CALL  PRIPLT  MAINA 

C  MAINA 

C  2.  RESTART  DATA  ON  UNIT  IRSOUT  CONTROLLED  BY  IRSOUT  •  0.  MAINA 

C  MAINA 

IF  ( IRSOUT. NE.O)  CALL  RSTART (5 , IRSOUT)  MAINA 

C  MAINA 

C  3.  SUBROUTINE  PRINT  ON  PRIMARY  OUTPUT  UNIT  CONTROLLED  BE  NPRT (3).  MAINA 
C  MAINA 

NPRT3  =  (NPRT (3) .EQ. 1)  MAINA 

IF  (NPRT(3) . GT. 1)  NPRT3  =  (MOD (I STEP, NPRT (3) ) .EQ.O)  MAINA 

IF  (NPRT3)  CALL  PRINT (6HMAIN3D)  MAINA 

C  MAINA 

C  4.  PROGRAM  VIEW  PLOT  DATA  ON  UNIT  1  CONTROLLED  BY  NPRT(l).  MAINA 

C  MAINA 

NPRT I  =  (NPRT(I) .EQ. I)  MAINA 

IF  (NPRT(l) .GT. 1)  NPRT1  =  (MOD ( ISTEP , NPRT ( 1 ) ) .EQ.O)  MAINA 

IF  (NPRT1 )  CALL  UNITKO)  MAINA 

C  MAINA 

C  5.  SUBROUTINE  ELTIME  ON  PRIMARY  OUTPUT  UNIT  CONTROLLED  BY  NPRT (2) .MAINA 
C  MAINA 

NPRT 2  =  (NPRT (2) .EQ. 1)  MAINA 

IF  (NPRT(2> .GT. 1)  NPRT 2  =  (MOD (ISTEP, NPRT (2) ) . EQ. 0)  MAINA 

IF  (NPRT2)  CALL  ELTIME (NPG, 1)  PAGE 

C  MAINA 

C  END  OF  INTEGRATION  LOOP.  MAINA 
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ISTEP  =  I STEP* 1  MAI HA 

IF  ( I STEP . LE . NSTEPS )  GO  TO  20  MAINA 

MAI  HA 

6.  SUBROUTINE  POSTPR  ON  PRIMARY  OUTPUT  UNIT  CONTROLLED  BY  NPRTI4) .MAINA 

MAINA 

50  IF  (NPRT4.GT.0)  END  FILE  8  MAINA 

IF  (NPRT(4) .  EQ.O  .OR.  NPRT(4) .EQ.4)  GO  TO  60  MAINA 

PRDT  =  1000. 0«DT  MAINA 

CALL  POSTPR  (PRDT)  MAINA 

IF  (NPRT2)  CALL  ELTIMEtNPG, 1)  PAGE 

MAINA 

7.  END  OF  RUN  -  CALL  ELTIME  IF  NOT  CALLED  ABOVE.  MAINA 

MAINA 

60  IF  ( .N0T.NPRT2)  CALL  ELTIME (NPG , 1 )  PAGE 

STOP  1  MAINA 

END  MAINA 


SUBROUTINE  ADJUST  (M.D1)  ADJUST 

REV  IV  07/23/86TW0PI 

IMPLICIT  REAL*8  (A-H.O-Z)  ADJUST 

COMkfON/CNSNTS/  PI , RADIAN, Q, THIRD , EPS (24)  ,  ADJUST 

*  UNITL,UNITM,UNITT,QRAVTY(3) .TWOPI  TWOPI 

COMMON/CDINT/  UU(4) ,QH(3,4) ,  ADJUST 

*  E(3,240) ,  F ( 5 , 240 ) ,GG(5,240) ,7(5,240) ,U(5,240) ,  ADJUST 

»  H .HPRINT , HS .TPRINT .TSTART , I CUT , IDBL , I FLAG  ADJUST 

COMMON/COMAIN/  VAR(240) ,DER(240) ,DT,H0 .EMAX.HMIN.RSTIME.  ADJUST 

*  ISTEP , NSTEPS , MDINT , NEQ , IRSIN , IRSOUT  ADJUST 

IF  (M.NE.l)  GO  TO  12  ADJUST 

ADJUST 

M  =  1:  ADJUST 

ADJUST 

DO  11  1=1. NEQ  ADJUST 

W  =  VAR(I)  -  GG(l.I)  ADJUST 

Z  =  DER(I)  -  GG(2 , I)  ADJUST 

ZZ  =  Z  -  GG(5,I)*W  -  GG(3 , I) *UU(3)  -  GG(4 , I) *UU(4)  ADJUST 

GG(3,I)  =  GG(3 , I )  +  ZZ«UU(1)  ADJUST 

GG(4,I)  =  GG(4 , I)  +  ZZ*UU(2)  ADJUST 

Y(1,I)  =  VAR(I)  ADJUST 

11  Y(2 , I)  =  DER(I)  ADJUST 

GO  TO  99  ADJUST 

12  IF  (M.EQ.3)  GO  TO  23  ADJUST 

ADJUST 

M  =  2,4,5:  ADJUST 

ADJUST 

HI  =  EPS(1)/H  ADJUST 

N2  =  NEQ/ 2  ADJUST 

DO  20  1=1, NEQ, 3  ADJUST 

ZA  =  0.0  ADJUST 

IF  (I.LE.N2)  GO  TO  20  ADJUST 

IF  (M.EQ.4)  GO  TO  16  ADJUST 

VARX  =  VAR(I  )  -  Yd  .1  )  ADJUST 

VARY  =  VARd  +  1)  -  Y ( 1 ,1*1)  ADJUST 

VARZ  =  VARU+2)  -  Y(  1,1  +  2)  ADJUST 

DERX  =  DER(I  )  -  Y(2 , I  )  ADJUST 

DERY  =  DERd  +  1)  -  Y(2,I  +  1)  ADJUST 

DERZ  =  DER(I+2)  -  Y(2,I+2)  ADJUST 

GO  TO  17  ADJUST 

16  VARX  =  VAR(I  )  -  U(1,I  )  ADJUST 

VARY  =  VAR (I + 1 )  -  U(1,I+1)  ADJUST 

VARZ  =  VAR  (I +  2)  -  Ud.I  +  2)  ADJUST 

DERX  =  DERd  )  -  U(2,I  )  ADJUST 

DERY  =  DERd  +  1)  -  U(2,I  +  1)  ADJUST 

DERZ  =  DERd +  2)  -  U(2,I  +  2)  ADJUST 

17  U(3 , I )  =  U(3 , I )  +  VARX»DERX  ♦  VARY»DERY  ♦  VARZ* DERZ  ADJUST 

U(4 , I)  =  U(4 , I)  ♦  VARX»*2  ♦  VARY«*2  ♦  VARZ»*2  ADJUST 

IF  (U(4 . I) .EQ.O.O)  GO  TO  18  FIXADJ 

ZA  =  HI  FIXADJ 


IF  (0(3,1) .LT.H1»U(4,I))  ZA  =  U(3 . I) /U(4 . I) 

FIXADJ 

18 

GG(5,I*2)  =  ZA 

FIXADJ 

00(5.1+1)  =  ZA 

ADJUST 

20 

00(5,1  )  =  ZA 

ADJUST 

00  TO  (99,21,99,23.25) ,M 

ADJUST 

ADJUST 

M  *  2: 

ADJUST 

ADJUST 

21 

DO  22  1  =  1, NEQ 

ADJUST 

ZA  =  00(5,1) 

ADJUST 

Y1  =  Y(4,I)  -  ZA«Y (3,1) 

ADJUST 

Y2  =  00(2,1)  -  ZA*GO( 1 , I) 

ADJUST 

Y3  =  DEB ( I )  -  ZA*VAR(I) 

ADJUST 

00(3,1)  =  -Y1»0H( 1 , 1)  +  Y2*QH(2 , 1)  ♦  Y3«OH(3,l) 

ADJUST 

00(4,1)  =  Y1*GH(1 ,2)  -  Y2»QH(2,2)  ♦  Y3«0H(3,2) 

ADJUST 

Y(l, I)  =  0 . 5» ( Y ( 1 , I) +VAB(I) ) 

ADJUST 

22 

Y(2 , 1)  =  0.5*(Y(2,I) +DER(I) ) 

ADJUST 

GO  TO  99 

ADJUST 

ADJUST 

M  =  3,4: 

ADJUST 

ADJUST 

23 

DO  24  1=1, HEQ 

ADJUST 

ZA  =  00(5,1) 

ADJUST 

Y1  »  00(2 , I)  -  ZA*GG(1 , I) 

ADJUST 

Y2  =  Y(2, I)  -  ZA*Y(1 ,1) 

ADJUST 

Y3  =  DEB ( I )  -  ZA*VAB(I) 

ADJUST 

00(3,1)  =  -Y1*GH( 1 ,3)  ♦  Y2*GH(2,3)  -  Y3«0H(3,3) 

ADJUST 

00(4,1)  =  Y1»0H( 1 ,4)  -  Y2»QH(2,4)  ♦  T3»GH(3,4) 

ADJUST 

U(  1 , 1)  =  VAB(I) 

ADJUST 

24 

U(2 , 1)  =  DEB ( I ) 

ADJUST 

00  TO  99 

ADJUST 

ADJUST 

M  =  5: 

ADJUST 

ADJUST 

25 

DO  26  1*1, HEQ 

ADJUST 

ZA  =  00(5,1) 

ADJUST 

Y1  =  00(2,1)  -  ZA»Q0(1,I) 

ADJUST 

Y2  =  DEB ( I )  -  ZA«VAB(I) 

ADJUST 

Y3  =  U(2,I)  -  ZA«D(1,I) 

ADJUST 

00(3,1)  =  -Y1»0H( 1 ,3)  ♦  Y2*QH(2 , 3)  -  Y3»OH(3,3) 

ADJUST 

00(4,1)  =  Y1»0H(1 ,4)  -  Y2*OH(2 ,4)  ♦  Y3«0H(3,4) 

ADJUST 

Y(l, I)  =  VAB(I) 

ADJUST 

26 

Y(2,I)  =  DEB ( I ) 

ADJUST 

99 

RETURN 

ADJUST 

END 

ADJUST 

SUBROUTINE  AIBBAG 


AIBBAG 

REV  IV  07/24/86SLIP 
AIRBAG  ROUTINE  CALLED  BY  SUBROUTINE  COHTCT  TO  DETERMINE  THE  INTER-AIRBAG 
ACTION  OF  THE  BAG  WITH  REACTION  PANELS  AND  BODY  SEGMENTS  BY  USE  OFAIRBAG 
SUBROUTINE  BGG.  THE  DIFFERENTIAL  PRESSURE , FORCE  AND  TORQUE  ON  THE  AIRBAG 


BAG  IS  EVALUATED  AND  THE  RESULTING  FORCE  AND  TORQUE  ON  THE  BODY  AIRBAG 
SEGMENTS  ARE  ADDED  TO  THE  U1  AND  U2  ARRAYS.  AIRBAG 

AIRBAG 

IMPLICIT  BEAL*B  (A-H.O-Z)  AIRBAG 

COMMON/CONTRL/  TIME , NSEG , NJNT , NPL , NBLT , NBAG , NVEH , NGRND ,  AIRBAG 

*  NS , NQ , NSD , NFLX , NHRNSS , NWINDF , NJNTF , HPRT (36) , NPG  PAGE 
COMMON/ SGMNTS/  D(3,3,30) ,WMEG(3,30) ,WMEGD(3,30) ,01(3,30) ,U2(3,30) .AIRBAG 

*  SEGLP(3,30) ,SEGLV(3,30) ,SEGLA(3,30) ,HSYM(30)  AIRBAG 

COMMON/ DESCRP/  PHI (3,30) ,W(30) ,RW(30) ,SR(4,60) ,HA(3,60) ,HB(3,60) .  SLIP 

*  RPHI(3,30) ,HT(3,3,80) ,SPRING(5 ,90) ,VISC(7,90) ,  AIRBAG 

*  JNT(30) ,IPIN(30) ,ISING(30) ,IGL0B(30) ,J0INTF(30)  AIRBAG 
COMMON/ JBARTZ/  MNPL(  30) ,MNBLT(  8) ,MNSEG(  30) ,MNBAG(  6) ,  AIRBAG 

«  MPL(3,5,30) , MBLT(3,5,8) ,MSEG(3 , 5 ,30) ,MBAG(3, 10,6)  ,  AIRBAG 

»  NTPL (  5 , 30) ,NTBLT(  5,8),NTSEG(  5,30)  AIRBAG 

COMMON/FORCES/PSF (7,70) ,BSF(4,20) ,SSF(10,40) ,BAGSF(3,20) .  NCFORC 

*  PRJNT(7,30) ,NPANEL(5) , NPSF , NBSF , NSSF , NBGSF  AIRBAG 

COMMON/CNTSRF /  PL ( 24 , 30) , BELT (20 , 8) , TPTS (6 , 8) . BD ( 24 , 40)  EDGE 

COMMON/CNSNTS/  PI .RADIAN, G, THIRD, EPS(24) .  AIRBAG 

»  UNITL,UNITM,UNITT,GRAVTY(3) ,TWOPI  TWOPI 

COMMON/ ABDAT A/  ZDEP(3,5) ,DBR(3,3,5) ,DPVCTB(3,5) ,DEPL0Y(3,5) ,  AIRBAG 

*  ABO, 5)  , B(9,4,5)  ,ZR(3,4,5)  ,BFB(3,4,5)  , DRR(9,4,5)  ,  AIRBAG 

»  VBAGG(5) ,VSCS(5) ,SPRK(5) ,CK(5) ,CMASS(5) ,CYMIN(5) ,  AIBBAG 

*  CYM0UT(5) ,BAGPV(5) ,PD(5) ,VBAG(5) ,V0LBP(5) ,  AIRBAG 

«  PCYV(5) ,PCYMIN(5) ,PVBAG(5) ,TV1 (3,4,5) ,TV2(3, 10,5) ,  AIRBAG 

»  SWITCH(5) ,PYM0UT(5) ,SCALE(5) ,PREVT , IFULL (6)  AIBBAG 

COMMON/CYDATA/  CYTD(5) ,CYPA(5) ,CYSP(5) ,CYT0(5) ,CYV0(5) ,CYCD(5) ,  AIBBAG 

*  CYK(5) ,CYR(5) ,CYAT(5) ,CYPV(5) ,CYCD0(5) ,CYA0(5) ,  AIRBAG 

«  CYPO (5) , CYSS (5) , CYLO ( 5 ) ,CYC(5) ,CYRH00(5) ,CYVMAX(5) .AIRBAG 

*  CY0RFC(5) ,CYRH0(5) ,CYT(5) ,CYP(5) ,CYV(5)  AIRBAG 

COMMON/TEMPVS/  TMP(9) ,TMP1 (3) ,T0RQ(3) ,FORCE(3,5) ,TORA(3,5) ,  AIRBAG 

«  TQB(3 , 10) , FRB<3 , 10) ,VOL(10) ,DELF(3) ,VOLP(4,5) ,FRA(4 , 5) AIRBAG 

NOTE:  THIS  COMMON/TEMPVS/  IS  SHARED  BY  AIRBAG  AND  AIRBGG.  AIRBAG 

CALL  ELTIMEd  ,24)  AIRBAG 

DELT  =  TIME-PREVT  AIRBAG 

NBGSF  =  0  AIRBAG 

DO  70  J= 1 , NBAG  AIRBAG 

IF  (MNBAG(J) .EQ.O)  GO  TO  70  AIRBAG 

IF  (IFULL(J) .LE.O)  GO  TO  69  AIRBAG 

CALL  AIRBGG (J)  AIRBAG 

AIRBAG 

COMPUTE  CMOUT:  MASS  FLOW  OUT  OF  BAG  AIRBAG 

BAGPV :  UNDISTORTED  BAG  VOLUME  AIRBAG 

AIRBAG 

IF  (PD(J) .GT.CYPV(J) )  CYMOUT(J)  =  PYMOUT(J)  AIBBAG 

*  ♦  DELT*CYORFC ( J) »DSQRT (PD ( J) )  AIRBAG 
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BAQPV(J)  =  CYPA(J) »  ( (CYMIN(J)  -CYMOUT(J) )*SWITCH(J)  )  ••CYK(J) 

BAG  IS  FULLY  INFLATED,  COMPUTE  DIFFERENTIAL  PRESSURE 

PD (J)  =  BAGPV (J) / (VBAG(J) -VOLBP (J) ) «*CYK(J)  -  CYPA(J) 

JB  =  NVEH  +  J 
KP  =  NPANEL(J) 

KB AG  =  MNBA3 ( J  > 

OPTIONAL  DIAGNOSTIC  OUTPUT 

IF  (NPRT(21) . NE.O)  WRITE(6,41) 

«  ( (FBB(I ,X) ,1=1 .3) , (TQB(I ,K) ,1=1 ,3) ,K=1 ,KBAG) , (FORCE (I, J) ,1*1,3) , 

*  (TORA(I.J) ,1=1,3) ,TORQ,((FRA(I,K) ,1=1,3) ,VOLP(K,J) ,K«1,KP) . 

«  (VOL(K) ,K=1 ,KBAG) ,VOLBP(J) ,CYM0UT(J) ,BAGPV(J) ,PD(J) 

FORMAT  (’OAIRBAG  COHTCT’ / ( IX, 8G14 .6) ) 

IF  (PD(J) .LT.O.O)  PD(J)  =  0.0 
IF  (PD(J).EQ.O.O)  GO  TO  46 

SET  UP  BAGSF  ARRAY  FOR  OUTPUT  ROUTINE 

KBGSF  =  NBGSF+5 
DO  42  K=1 ,KP 

KBGSF  =  KBGSF+1 
DO  42  1=1,3 

BAGSF (I, KBGSF)  =  PD(J) »FRA(I ,K) 

DO  45  1=1, KBAG 

KBGSF  =  KBGSF+1 
IF  (VOL(I) .EQ.O.O)  GO  TO  45 
M  =  MBAG ( 2 , I , J ) 


FINAL  COMPUTATIONS  OF  FORCE  AND  TOBQUE  ON  AIRBAG 

DO  44  K=1 ,3 

FRB(K.I)  =  PD(J) »FRB(K, I) 

BAGSF (K, KBGSF)  =  FRB(K.I) 

Ul(K.M)  =  Ul(K.M)  -  FRB(K.I) 

U2 (K ,M)  =  U2(K,M)  +  PD(J) »TQB(K, I) 

CONTINUE 
DO  47  K= 1 ,3 

FORCE (K.J)  =  PD(J) «FORCE(K,J) 

TORA  (K.J)  =  PD(J)«TORA  (K,J) 

IF  (VOLP(l.J) .NE.O.O)  GO  TO  55 

AIRBAG  IS  NOT  INTERSECTING  PRIMABY  REACTION  PANEL. 

COMPUTE  ARTIFICIAL  FORCE  AND  TORQUE  WITH  A  LINEAR  SPRING  FUNCTION 
IN  AN  ATTEMPT  TO  TIE  +X  SEMIAXIS  ENDPOINT  OF  AIRBAG  TO  DEPLOYMENT 
POINT  ON  REACTION  PANEL. 

DO  51  K=1 ,3 
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51  TMP(K)  =  BFB(K.l.J)  ♦  ZDEP(K.J)  AIRBAG 

CALL  D0T31  (D ( 1 , I ,NVEH) ,TMP ,TMP1)  AIRBAG 

DO  52  K=1 ,3  AIRBAG 

DELF(K)  =  TMPl(K)  ♦  SEGLP (K ,NVEH)  -  SEGLP(K.JB)  AIRBAG 

52  TMP(K)  =  BD(K+3, JB)  AIRBAG 

TMP(l)  =  TMP(l)  ♦  BD(1,JB)  AIRBAG 

CALL  DOT31  (D(l , 1 , JB) ,TMP ,TMP1)  AIRBAG 

DO  53  K=  1 ,3  AIRBAG 

DELF(K)  =  SPRK(J)«(DELF(K) -TMPl(K))  AIRBAG 

BAGSF(K,NBGSF+5)  =  DELF(K)  AIRBAG 

53  FORCE (K,J)  =  FORCE (K.J)  +  DELF(K)  AIRBAG 

CALL  MAT31  (D( 1 , 1 , JB) .DELF.TMP1)  AIRBAG 

CALL  CROSS  (TMP.TMPl ,DELF)  AIRBAG 

DO  54  K= 1 ,3  AIRBAG 

54  TORA(K.J)  *  TORA(K.J)  ♦  DELF(K)  AIRBAG 

55  XDD  =  CYMIV(J)  -  C YMODT(J)  +  W(JB)  AIRBAG 

FMASS  =  CMASS ( J) *XDD/G  AIRBAG 

TMASS  =  CMASS (J) * (XDD*W(JB) *2. 0/3. 0) /G  AIRBAG 

DO  56  1=1,3  AIRBAG 

56  TMP(I)  =  WMEG(I , JB) *PHI (I , JB)  AIRBAG 

CALL  CROSS  (WMEG(l.JB) .TMP.TMPl)  AIRBAG 

DO  57  1=1,3  AIRBAG 

SEGLA(I.JB)  =  FORCE ( I, J) /FMASS  *  GRAVTY ( I )  AIRBAG 

57  WMEGD(I.JB)  =  (TORA(I . J) /TMASS-TMP1 (I) ) »RPHI (I , JB)  AIRBAG 

69  NBGSF  =  HBGSF  ♦  5  ♦  HP ABEL (J)  +  MHBAG(J)  AIRBAG 

70  CONTINUE  AIRBAG 

CALL  ELTIME(2,24)  AIRBAG 

RETURN  AIRBAG 

END  AIRBAG 


58 


SUBROUTINE  AIRBGG(J) 


C 

C 

C 

C 


REV  III. 5 


AIRBQQ 
10/ 17/85EDGE 


CALLED  BY  SUBROUTINES  AIRBAG  AND  AIRBG3  TO  COMPUTE  VOLUMES  OF 
INTERSECTION  BETWEEN  AIRBAGS  AND  PANELS  AND  SEGMENTS. 


IMPLICIT  REAL » 8  (A-H.O-Z) 

COMMON/CONTRL/  TIME , NS EG . NJNT , NPL , NBLT . NBAG . NVEH , NGRND , 

»  NS , NQ , NSD , NFLX , NHRNSS , NWINDF , NJNTF , NPRT ( 36 ) ,NPG 


AIRBGG 

AIRBGG 

AIRBGG 

AIRBGG 

AIRBGG 

PAGE 


COMMON/ SGMNTS/  D(3,3,30) ,WMEG(3,30) ,WMEGD(3,30) , U1 (3,30) ,U2(3,30) .AIRBGG 


»  SEGLP (3 , 30) , SEGLV (3 , 30) ,SEGLA(3,30) ,NSYM(30) 

COMMON/ JBARTZ /  MNPL(  30) ,MNBLT(  8) ,MNSEG(  30) ,MNBAG(  6) 
»  MPL(3,5,30) , MBLT (3 , 5,8) ,MSEG(3,5,30) ,MBAG(3 , 10 .6) 

»  NTPL (  5,30) ,NTBLT(  5,8).NTSEG(  5,30) 

COMMON/FORCES/PSF (7,70) ,BSF(4,20) ,SSF(10,40) ,BAGSF(3,20) , 

«  PRJNT (7,30), NPANEL ( 5 ) , NPSF , NBSF , NSSF , NBGSF 

COMMON/CNTSRF /  PL(24,30) ,BELT(20,8) ,TPTS(6,8) ,BD(24,40) 
COMMON/ABDATA/  ZDEP(3,5) ,DBR(3,3,5) ,DPVCTR(3,5) ,DEPL0Y(3,5) , 

*  ABO, 5)  ,B(9,4,5)  ,ZR(3,4,5)  ,BFB(3,4,5)  ,DRR(9,4,5)  . 

«  VBAGG(5) , VSCS (5) ,SPRK(5) ,CK(5) ,CMASS(5) ,CYMIN(5) , 

»  CYMOUT (5) , BAGPV(5) ,PD(5) ,VBAG(5) ,VOLBP(5) , 

»  PCYV(5) ,PCYMIN(5) ,PVBAG(5) ,TV1 (3,4,5) ,TV2(3,10,5) 

»  SWITCH(5) ,PYM0UT(5) ,SCALE(5) ,PREVT,IFULL(6) 

COMMON/CYDATA/  CYTD(5) ,CYPA(5) ,CYSP(5) ,CYT0(5) ,CYV0(5) ,CYCD(5) , 


AIRBGG 

AIRBGG 

AIRBGG 

AIRBGG 

NCFORC 

AIRBGG 

EDGE 

AIRBGG 

AIRBGG 

AIRBGG 

AIRBGG 

AIRBGG 

AIRBGG 

AIBBGG 


* 

CYK(5) , CYR(5) ,CYAT(5) ,CYPV(5) ,CYCD0(5) ,CYA0(5) , 

AIRBGG 

ft 

CYPO (5) , CYSS (5) , CYLO (5) ,CYC(5) ,CYRH00(5) .CYVMAXC5) .AIRBGG 

1 

CYORFC (5) .CYRHO (5) ,CYT(5) ,CYP(5) ,CYV(5) 

AIRBGG 

COMMON/ TEMP VS/  TMP(9) ,TMP1(3) ,T0RQ(3) ,F0RCE(3,5) ,TORA(3,5) , 

AIRBGG 

* 

TQB (3 , 10) , FRB(3 , 10) ,VOL(10) ,DELF(3) ,VOLP(4,5) ,FRA(4 , 5) AIRBGG 

c 

NOTE:  THIS 

COMMON/ TEMP VS/  IS  SHARED  BY  AIRBAG  AND  AIRBGG. 

AIRBGG 

JB  =  NVEH 

+  J 

AIRBGG 

VOLBP(J)  = 

0.0 

AIBBGG 

c 

AIRBGG 

c 

COMPUTE  THERMODYNAMIC  PROPERTIES  OF  AIRBAG 

AIRBGG 

c 

CYRHO 

:  DENSITY 

AIRBGG 

c 

CYT 

:  TEMPERATURE 

AIRBGG 

c 

CYP 

:  PRESSURE 

AIRBGG 

c 

CYMIN 

:  MASS  FLOW  INTO  BAG 

AIRBGG 

c 

VBCALC 

:  CALCULATED  VOLUME 

AIRBGG 

c 

AIRBGG 

0  =1.0 

AIRBGG 

Q1  =  1.0 

AIRBGG 

02  =  1.0 

AIRBGG 

IF  (TIME. 

LE.CYTD(J) )  GO  TO  13 

AIRBGG 

Q  =  1.0  + 

CYC ( J) » (TIME-CYTD ( J) ) 

AIRBGG 

CYK1  =  2 . 0/ (CYK ( J) -1.0) 

AIRBGG 

Q1  =  1 . 0/Q»»CYKl 

AIRBGG 

Q2  =  1 . 0/0»» (CYK(J) »CYK1) 

AIRBGG 

13  CYRHO (J)  = 

CYRHOO ( J) *Q1 

AIBBGG 

CYT(J) 

CYTO ( J) /Q»»2 

AIRBGG 

CYP(J) 

CYPO ( J) »Q2 

AIRBGG 
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CYMIN(J)  =  CYVO ( J) * (CYRHOO ( J) -CYRHO ( J) ) 

CYV(J)  =  CYVMAX(J)«(1.0-Q2) 

IF  (TIME.LT.CYTD(J) )  GO  TO  31 

IF  (BD(1,JB) .EQ.O.O)  GO  TO  31 

IF  (TIME. LE. 0.0)  GO  TO  31 

VOLB  =  0.0 

COMPUTE  AIRBAG  ELLIPSOID  MATBIX  AND  ZEBO  BAG  FOBCE  AMD  TOBQUE . 

IF  (IFULL(J) .HE.O)  GO  TO  21 
SAB  =  SCALE (J) »AB( 1 , J) 

DO  19  1=1,3 

TMP(I)  =  DEPLOY (I , J)  +  SAB»DPVCTR(I , J) 

CALL  D0T31  (D ( 1 , 1 , NVEH) , TMP , SEGLP ( 1 , JB) ) 

DO  20  1=1,3 

SEGLP (I , JB)  =  SEGLP (I , JB)  ♦  SEGLP ( 1 . NVEH) 

DO  23  1=1,3 

FOBCE (I , J)  =  0.0 
TOBA  (I , J)  =  0.0 

COMPUTE  FOBCE, TOBQUE  AND  VOLUME  OF  INTERSECTION 
OF  AIBBAG  WITH  REACT I OH  PANEL  ELLIPSOIDS. 

KP  =  NPANEL(J) 

DO  26  K=1  ,KP 

CALL  BGG( 

*  BD (7 , JB) .SEGLP ( 1 , JB) ,D(1,1,JB) ,BD(4,JB) ,SEGLV(1,JB) ,WMEG(1,JB) 

«  B ( 1 ,K,J) , SEGLP (1, NVEH) ,D(1,1,HVEH) ,BFB(1,K,J) , SEGLV ( 1 , NVEH) 

»  WMEG(l.NVEH) ,VSCS(J) ,IFULL(J) ,TV1(1,K,J) , 

*  FBA(l.K) ,TOBQ,TQB,VOLP(K,J)) 

VOLBP(J)  =  VOLBP(J)  ♦  VOLP(X.J) 

DO  26  1=1,3 

FOBCE ( I , J)  =  FOBCE (I , J)  +  FBA(I.K) 

TOBA  (I,J)  =  TOBA  (I . J)  +  TOBQ(I) 

COMPUTE  FOBCE, TOBQUE  AND  VOLUME  OF  INTERSECTION 
OF  AIRBAG  WITH  CONTACTING  SEGMENT  ELLIPSOIDS. 

KB AG  =  MNBAG(J) 

DO  30  1=1, KBAG 

M  =  MBAG ( 2 , I , J ) 

MM  =  MB  AGO ,  I ,  J) 

CALL  BGG( 

*  BD(7 , JB) , SEGLP (1 ,JB) ,D(l,l,JB) ,BD(4,JB) ,SEGLV(1,JB) ,WMEG(1,JB) 

»  BD (7 ,MM) , SEGLP ( 1 ,M) ,D(1,1,M) ,BD(4,IM) ,SEGLV(1,M) ,WMEG(1,M) , 

«  VSCS(J) , I FULL (J) ,TV2 (1,1 , J) ,FRB(1,I) ,T0BQ,TQB(1 ,1) ,V0L(I)) 

IF  (VOL(I) .EQ.O.O)  GO  TO  30 
VOLB  =  VOLB  +  VOL(I) 

DO  28  K=1 ,3 

FORCE (K . J)  =  FORCE (K,J)  ♦  FRB(K,I) 
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28  TORA  (K.J)  =  TORA  (K,J)  ♦  TORQ(K) 

30  CONTINUE 

VOLBP(J)  =  VOLBP(J)  +  VOLB 

31  RETURN 
END 
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SUBROUTINE  AIRBQ1  AIRBGI 

REV  IV  07/24/86SLIP 

READS  AND  PRINTS  THE  INPUT  CARDS  THAT  DESCRIBE  THE  PHYSICAL  AIRBG1 

DIMENSIONS  AND  GAS  DYNAMICS  OF  THE  AIRBAG  RESTRAINTS  AND  AIRBG1 

PERFORMS  INITIALIZATION  REQUIRED  BY  THE  AIRBAG  ROUTINE.  AIRBG1 

AIRBG1 

IMPLICIT  REAL»8  (A-H.O-Z)  AIRBG1 

COMMON/CONTRL/  TIME, NSEG , NJNT , NPL , NBLT , NBAG , NVEH , NGRND ,  AIRBG1 

*  NS , NQ , NSD , NFLX , NHRNSS , NWI NDF , NJNTF , NPRT ( 36 ) , NPG  PAGE 

COMMON/ SGMNTS/  D(3,3,30) ,WMEG(3,30) ,WMEGD(3,30) ,U1(3,30) ,U2(3,30) , AIRBG1 

*  SEGLP(3,30) ,SEGLV(3,30) ,SEGLA(3,30) ,NSYM(30)  AIRBG1 

COMMON/DESCRP/  PHI (3,30) ,11(30) ,RW(30) ,SR(4,60) ,HA(3,60) ,HB(3,60) ,  SLIP 

»  RPHI (3 , 30) ,HT (3 , 3 ,60) .SPRING (5 ,90) , VISC (7 ,90) ,  AIRBG1 

*  JNT(30) ,IPIN(30) ,ISING(30) , IGLOB(30) ,J0INTF(30)  AIRBG1 

C0MM0N/F0RCES/PSF(7 ,70) ,BSF(4,20) ,SSF(10,40) ,BAGSF(3,20) ,  NCFORC 

*  PRJNT(7,30) ,NPANEL(5) , NPSF , NBSF , NSSF , NBGSF  AIRBG1 

COMMON/TITLES/  DATE(3) ,C0MENT(40) ,VPSTTL(20) ,BDYTTL(5) ,  AIRBGI 

*  BLTTTL(5,8) ,PLTTL(5,30) ,BAGTTL(5,6) ,SEG(30) ,  AIRBGI 

»  J0INT(30) ,CGS(30) ,JS(30)  AIRBGI 

REAL  DATE , COMENT , VPSTTL , BDYTTL , BLTTTL , PLTTL , BAGTTL , SEG , JOINT  AIRBGI 

LOGICAL* 1  CGS.JS  AIRBGI 

COMMON/CNSNTS/  PI .RADIAN, G. THIRD, EPS (24) ,  AIRBGI 

*  UNITL,UNITM,UNITT,GRAVTY(3) .TWOPI  TWOPI 

COMMON/CNTSRF /  PL (24 ,30) ,BELT(20 ,B) ,TPTS (6 , 8) ,BD(24 ,40)  EDGE 

COMMON/ INTEST/  SGTEST (3 ,4 ,30) ,XTEST(3, 120) ,SEGT(120) ,REGT(120)  AIRBGI 

REAL  SEGT  AIRBGI 

COMMON/ ABDATA/  ZDEP (3 , 5) ,DBR(3 ,3 , 5) ,DPVCTR(3 , 5) ,DEPL0Y(3 ,5) ,  AIRBGI 

*  AB (3 , 5) , B (9 , 4 , 5) ,ZR(3 , 4 , 5) , BFB (3 ,4,5) ,DRR(0 ,4 ,5) ,  AIRBGI 

»  VBAGG(5) ,VSCS(5) ,SPRK(5) ,CK(5) ,CMASS(5) ,CYMIN(5) ,  AIRBGI 

*  CYM0UT(5) ,BAGPV(5) , PD ( 5 ) ,VBAG(5) ,V0LBP(5) ,  AIRBGI 

»  PCYV(5) ,PCYMIN(5) ,PVBAG(5) ,TV1 (3,4,5) ,TV2 (3 , 10,5) ,  AIRBGI 

»  SWITCH(5) ,PYM0UT(5) ,SCALE(5) ,PREVT,IFULL(6)  AIRBGI 

COMMON/CYDATA/  CYTD(5) ,CYPA(5) ,CYSP(5) ,CYT0(5) ,CYV0(5) ,CYCD(5) .  AIRBGI 

»  CYK(5) ,CYR(5) ,CYAT(5) ,CYPV(5) ,CYCD0(5) ,CYA0(5) ,  AIRBGI 

«  CYPO (5) ,CYSS (5) ,CYLO (5) ,CYC(5) ,CYRH00(5) ,CYVMAX(5) .AIRBGI 

*  CY0RFC(5) ,CYRH0(5) ,CYT(5) ,CYP(5) ,CYV(5)  AIRBGI 

COMMON/ TEMP VS/  TMP (9) ,TMP 1(3)  AIRBGI 

DIMENSION  YB(3) ,YP(3) ,IDYPR(3)  AIRBGI 

REAL  BAG (6)  AIRBGI 

DATA  BAG/4HBAG1 , 4HBAG2 , 4HBAG3 , 4HBAG4 , 4HBAG5 , 4HBAG  /  AIRBGI 

DATA  IDYPR/3 ,2,1/  AIRBGI 

DATA  MAXNPL/4/ .MAXSEG/30/  CHGIII 

AIRBGI 

MAKE  ROOM  FOR  BAG  DATA  IN  SEGMENT  ARRAYS  BETWEEN  VEH  AND  GRND.  AIRBGI 

AIRBGI 

MS EG  =  0  CHGIII 

IF  ( NVEH. GT. NSEG)  MSEG  =  NVEH  -  NSEG  CHGIII 

L  =  NSEG  ♦  NBAG  *  MSEG  ♦  1  CHGIII 

K  =  NSEG  ♦  MSEG  ♦  1  CHGIII 

W(L)  =  W(K)  AIRBGI 


RW(L)  =  RW(K)  AIRBQ1 

SEG(L)  =  SEG(K)  AIRBG1 

ISING(L)  =  ISING(K)  AIRBG1 

IF  (L-l.GT.NJNT)  JHT  (L-l)  =  0  AIRBG1 

IF  (L-l.GT.NJNT)  IPIN(L-l)  =  0  AIRBG1 

DO  19  1=1,3  AIRBG1 

SEGLP(I , L)  =  SEGLPtl , K)  AIRBG1 

SEGLV(I , L)  =  SEGLV(I.K)  AIRBG1 

SEGLA(I.L)  =  SEGLA(I , K)  AIRBG1 

WlfEG  (I  ,L)  =  WMEG  ( I , K)  AIRBG1 

WMEGD(I.L)  =  WMEGD(I.K)  AIRBG1 

PHI  (I.L)  =  PHI  (I ,K)  AIRBG1 

RPHI  (I.L)  =  RPHI  (I ,K)  AIRBG1 

DO  18  J= 1 , 3  AIRBG1 

D(I,J,L)  =  D(I,J,K)  AIRBG1 

18  SGTESTd ,  J.L)  =  SGTEST(I,J,K)  AIRBG1 

19  SGTESTd,  4,  L)  =  SGTESTd,  4,  K)  AIRBG1 

NGRND  =  NSEG  +  MB AG  ♦  MS EG  +  1  CHGIII 

IF  ( NGRND. GT.MAXSEG)  STOP  75  CHGIII 

DO  40  J  = 1 , NBAG  AIRBG1 

JB  =  NVEH  +  J  AIRBG1 

C  AIRBG1 

C  READ  AND  PRINT  CARDS  D.4.A  -D.4.F  FOR  THE  JTH  AIRBAG.  AIRBG1 

C  AIRBG1 

READ  (5,13)  (BAGTTLd  ,  J)  ,  I  =  1 ,5)  , NPANEL(J)  ,  AIRBG1 

»  (AB(I,J) ,1=1,3)  ,  (BD(I,JB) ,1=4,6) ,  AIRBG1 

*  YB,  (ZDEPd.J)  ,1  =  1,3)  ,  AIRBG1 

*  W(JB) ,CYTD(J) ,CYPA(J) ,CYSP(J) ,CYT0(J) ,CYV0(J) .  AIRBG1 

*  CYCD(J) ,CYK(J) ,CYR(J) ,CYAT(J) ,CYPV(J) ,CYCDO(J) ,  AIRBG1 

»  CYAO(J) , SPRK(J) ,VSCS(J) ,CK(J) ,CMASS(J)  AIRBG1 

13  FORMAT  (5A4 , 14/ (6F12 . 0) )  AIRBG1 

IF  (NPANEL(J) . GT.MAXNPL)  STOP  78  CHGIII 

IF  (M0D(J,2) . EQ . 1 )  WRITE (6 , 15)  NPG  PAGE 

IF  (MOD (J , 2) . EQ . 1  NPG=NPG+1  PAGE 

15  FORMAT (' 1 ',  122X,  ’ PAGE*  ,  15/ '  AIRBAG  INPUTSM05X, ’CARDS  D. 4’ )  PAGE 
WRITE(6 , 14)  J.  (BAGTTLd,  J)  ,  I  =  1,5  ),  AIRBG1 

«  (AB(I,J) ,1=1,3)  ,  (BD(I,JB) ,1=4,6) ,  AIRBG1 

*  YB. (ZDEP(I,J), 1=1, 3),  AIRBG1 

»  W(JB) ,CYTD(J) ,CYPA(J) ,CYSP(J) ,CYTO(J) ,CYVO(J) ,  AIRBG1 

*  CYCD(J) ,CYK(J) ,CYR(J) ,CYAT(J) ,CYPV(J) ,CYCDO(J) ,  AIRBG1 

»  CYAO(J) , SPRK(J) ,VSCS(J) ,CK(J) , CMASS(J)  AIRBG1 

14  FORMAT ( ' 0  AIRBAG  NO. ’ ,I4,4X,5A4//  AIRBG1 

»  29X/AIR  BAG  SEMI  AXES '  ,46X, ’C.G.  OFFSET ’/6X,  6020. 9//  AIRBG1 

«  15X,'YAW’ ,16X, ’PITCH', 15X, ’ROLL’, 30X, ’DEPLOYMENT  POINT’  AIRBG1 

»  /6X.6G20.9//  AIRBG1 

«  15X, ’ XBM’ . 16X, ’ CYTD’ , 18X, ’CYPA’ , 16X, ’CYSP’ , 16X, ’CYTO’ , 16X, ’CYVO’  AIRBG1 

*  /6X.6G20.9//  AIRBG1 

*  14X, ’CYCD’ , 17X, ’CYK’ , 17X, ’CYR’ , 16X, ’CYAT’ ,16X, ’CYPV’ , 16X, ’CYCDO’  AIRBG1 

*  /6X.6G20.9//  AIRBG1 

»14X, ’CYAO’ , 16X, ’SPRK’ , 16X, ’VSCS’ , 17X, ’CK’ , 17X, ’CMASS’/6X,5G20.9)  AIRBG1 


r 
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KP  =  NPANEL ( J)  AIRBQ1 

DO  25  K=1 ,KP  AIRBG1 

C  AIRBQ1 

C  READ  AND  PRINT  CARDS  D.4.G  AND  D.4.H  FOR  THE  KTH  PANEL  TO  AIRBGI 

C  CONTACT  THE  JTH  AIRBAG.  THESE  PANELS  ARE  APPROXIMATED  B7  AIRBG1 

C  ELLIPSOIDS.  THE  FIRST  PANEL  (K=l>  IS  THE  REACTION  PANEL  THAT  AIRBG1 

C  INCLUDES  THE  DEPLOYMENT  POINT.  AIRBG1 

C  AIRBGI 

READ (5 ,11)  (B(I,K,J) .1=1,3) . (BFB(I.K.J) ,1=1,3) ,  AIRBGI 

*  (ZRU.K.J)  ,1  =  1.3)  ,YP  AIRBGI 

11  FORMAT (6F1 2.0)  AIRBGI 

WRITEI6 , 12)  K,(B(I.K,J) ,1=1,3) ( (BFB(I , K,J) ,1=1,3) ,  AIRBGI 

*  (ZR(I.K,J) ,1=1,3) ,YP  AIRBGI 

12  FORMAT! '0  PANEL  NO. ’ ,14//  AIRBGI 

«  24X, ’ PANEL  ELLIPSOID  SEMIAXES’ ,43X, ’C.G.  OFFSET’ /6X.6G20 . 9//  AIRBGI 

*  29X, ’PANEL  LOCATION’ ,32X, ’YAW’ ,16X, 'PITCH’ , 15X, ’ROLL’ /6X.6G20. 9)  AIRBGI 

C  AIRBGI 

C  CONVERT  B  FROM  ELLIPSOID  SEMIAXES  TO  MATRIX  AIRBGI 

C  AIRBGI 

DO  21  1=1,3  AIRBGI 

21  TMP(I)  =  B(I ,K, J)  AIRBGI 

DO  22  1=1,9  AIRBGI 

22  B(I,K.J)  =  0.0  AIRBGI 

DO  23  1=1,3  AIRBGI 

23  B (4*1-3 ,K ,J)  =  1.0/TMP(I)**2  AIRBGI 

CALL  DBCYPR  (DRRfl ,K, J) ,YP,IDYPR)  AIRBGI 

CALL  MAT33  (B(l ,K, J) ,DBB( 1 ,X, J) ,TMP)  AIRBGI 

CALL  D0T33  (DRR(1,K,J) ,TMP,B( 1 ,K, J) }  AIRBGI 

CALL  D0T31  (DRRfl ,K,J) ,BFB(1 ,K,J) ,TMP)  AIRBGI 

DO  24  1=1,3  AIRBGI 

24  BFB(I.K.J)  =  TMP(I)  +  ZR(I,K,J)  AIRBGI 

25  CONTINUE  AIRBGI 

C  AIRBGI 

C  COMPUTE  GEOMETRY  OF  DEPLOYMENT  POINT  ON  FIRST  PANEL.  AIRBGI 

C  AIRBGI 

CALL  DRCYPR  (DBR( 1 , 1 , J) , YB , IDYPR)  AIRBGI 

CALL  D0T31  (DRRfl , 1 ,J) ,ZDEP(1 ,J) , DEPLOY (1 ,J) )  AIRBGI 

DO  31  1=1,3  AIRBGI 

DPVCTRd  ,  J)  =  -DBR(  1 , 1 ,  J)  AIRBGI 

31  DEPLOY (I , J)  =  DEPLOY (I , J)  ♦  BFB(I,1,J)  AIRBGI 

CALL  PANEL  (DBR( 1 , 1 , J) ,DEPLOY( 1 , J) , JB)  AIRBGI 

C  AIRBGI 

C  INITIALIZATION  OF  AIRBAG  GEOMETRY.  AIRBGI 

C  AIRBGI 

VBAGG(J)  =  4.0/3. 0*PI*AB ( 1 , J) »AB (2 , J) *AB (3 , J)  AIRBGI 

PHI ( 1 , JB)  =  (AB(2,J)**2+AB(3,J)#«2)/5.0  AIRBGI 

PHI (2, JB)  =  (AB (3 , J) »»2+AB ( 1 , J) **2) /5 . 0  AIRBGI 

PHI (3 , JB)  =  (AB(1 , J) »»2+AB (2 , J) »»2) /5 .0  AIRBGI 

JNT(JB-l)  =  0  AIRBGI 

IPIN(JB-l)  =  0  AIRBGI 


SEG(JB)  =  BAG(J) 

IF  (NBAG.EQ. 1)  SEG(JB)  =  BAG (6) 

ISING(JB)  =  -1 
RW(JB)  =  G/W(JB) 

DO  36  1=1,3 

BD(I.JB)  =  0.0 

RPHI(I.JB)  =  1.0/PHI (I, JB) 

DO  36  K= 1 ,4 

16  SGTEST(I ,K , JB)  =  0.0 

DO  35  1=7,24 

15  BD(I,JB)  =  0.0 
I FULL (J)  =  0 
CYMOUT(J)  =0.0 
PYMOUT(J)  =0.0 
DO  38  1=1,3 

DO  37  K=1 ,4 

17  TVKI.K.J)  =  0.0 
DO  38  K= 1 , 10 

18  TV2 (I ,K, J)  =  0.0 

AIR  CYLINDER  INITIALIZATION 

CYPO(J)  =  CYSP ( J) +CYPA(J) 

CYSS(J)  =  DSQRT (CYK ( J) #CYR(J) »CYTO (J) »G) 

CYLO(J)  =  CYVO(J) /CYAT(J) 

CYK1  =  CYK(J)-1.0 
CYK2  =  0.5» (CYK(J) +1.0) 

CYK3  =  CYK2»» (-CYK2/CYX1) 

CYC ( J)  =  0 . 5*CYK1»CYSS ( J) »CYCD(J) /CYLO ( J) «CYK3 
CYRHOO(J)  =  CYPO (J) / (CYR(J) »CYTO (J) ) 

CYVMAX(J)  =  CYVO (J) /CYK{J) *CYPO(J) /CYPA(J) 

CYORFC(J)  =  CYCDO (J) «CYAO (J) »G«DSQBT (2. 0»CYPA(J) »CYK(J) ) 
IF  (NPRT(22) . NE.O)  WRITE(6,39) 

»  (SEGLP(I.JB) ,1  =  1,3) . (SEGLV(I.JB) ,1  =  1 ,3) ,  «WEG(I ,JB) 
«  VBAGG(J)  ,CYPO (J)  ,CYSS(J)  ,CYC(J)  ,CYRHOO(J)  ,CYV1IAX(J) 

39  FORMAT ( ' 0  AIRBAG  SINPUT' / ( IX, 9G14 .6) ) 

40  CONTINUE 
PREVT  =0.0 
RETURN 

END 
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SUBROUTINE  AIRBG3 ( IRESET)  AIRBG3 

C  REV  IV  07/23/86TWOPI 

C  AIRBG3 

C  THIS  SUBROUTINE  IS  CALLED  BY  SUBROUTINE  UPDATE  AT  START  ( IRESET= 1 ) AIRBG3 

C  AND  END  (I RESET1 2)  OF  EACH  INTEGRATION  STEP  TO  DETERMINE  IF  EACH  AIRBG3 

C  AIRBAG  HAS  BEEN  FULLY  INFLATED.  AIRBG3 

C  AIRBG3 

IMPLICIT  REAL *8  (A-H.O-Z)  AIRBG3 

COMMON/CONTRL/  T I ME , NS  EG , N JNT , NPL , NBLT , NBAG , NVEH , NGRND ,  AIRBG3 

*  NS , NQ , NSD , NFLX , NHRNSS , NWINDF , NJNTF , NPRT (36) , NPG  PAGE 
COMMON/ SGMNTS/  D(3,3,30) ,WMEG(3,30) ,WMEGD(3,30) ,U1(3.30) ,U2(3,30) , AIRBG3 

»  SEGLP(3,30) ,SEGLV(3,30) ,SEGLA(3,30) ,NSYM(30)  AIRBG3 

COMMON/ JBARTZ/  MNPLt  30),MNBLT(  8) ,MNSEG(  30) ,MNBAG(  6),  AIRBG3 

*  MPL (3 , 5,30) , MBLT (3 , 5,8) ,MSEG(3 ,5 ,30) , MBAG(3 , 10,6) ,  AIRBG3 

*  NTPL(  5 ,30) ,NTBLT(  5,8),NTSEG(  5,30)  AIRBG3 

COMMON/FORCES/PSF (7 ,70) ,BSF(4,20) ,SSF(I0,40) ,BAGSF(3,20) ,  NCFORC 

*  PRJNT(7,30) ,NPANEL(5) ,NPSF ,NBSF ,NSSF .NBGSF  AIRBG3 

COMMON/CNTSRF /  PL (24 , 30) , BELT (20 , 8) , TPTS (0 , 8) , BD (24 , 40)  EDGE 

COMMON/CNSNTS/  PI .RADIAN, G, THIRD, EPS(24) ,  AIRBG3 

«  UNITL,UNITM,UNITT,GRAVTY(3) .TWOPI  TWOPI 

COMMON/ABDATA/  ZDEP(3,5) ,DBR(3,3,5) ,DPVCTR(3,5) ,DEPL0Y(3,5) ,  AIRBG3 

*  AB(3,5) ,B(9,4,5) ,ZR(3,4,5) ,BFB(3,4,5) ,DRR(9,4,5) ,  AIRBG3 

»  VBAGG(5) ,VSCS(5) ,SPRK(5) ,CK(5) ,CMASS(5) ,CYMIN(5) ,  AIRBG3 

»  CYM0UT(5) ,BAGPV(5) ,PD(5) , VBAG(5) , V0LBP(5) ,  AIRBG3 

»  PCYV(5) , PCYMIN(5) , PVBAG (5) ,TV1 (3 , 4 , 5) ,TV2 (3 ,10,5) ,  AIRBG3 

*  SWITCH(5) ,PYM0UT(5) ,SCALE(5) ,PREVT, IFULL (6)  AIBBG3 

COMMON/CYDATA/  CYTD(5) ,CYPA(5) ,CYSP(5) ,CYT0(5) ,CYV0(5) ,CYCD(5) ,  AIRBG3 

*  CYK(5) ,CYR(5) ,CYAT(5) ,CYPV(5) ,CYCD0(5) ,CYA0(5) ,  AIRBG3 

»  CYPO (5) , CYSS (5) , CYLO (5) ,CYC(5) ,CYRH00(5) ,CYVMAX(5) , AIRBG3 

»  CY0RFC(5) ,CYRH0(5) ,CYT(5) ,CYP(5) ,CYV(5)  AIRBG3 

COMMON/TEMPVS/  TMP (9) ,TMP1 (3)  AIRBG3 

CALL  ELTIME ( i , 29)  AIRBG3 

JRESET  IRESET  AIRBG3 

IF  (JRESET. EQ. I)  PREVT  =  TIME  AIRBG3 

NBGSF  =  0  AIRBG3 

DO  50  J= 1 , NBAG  AIRBG3 

IF  (MNBAG(J) . EQ. 0)  GO  TO  50  AIRBG3 

JB  =  NVEH  +  J  AIRBG3 

JFULL  =  IFULL (J)  +  2  AIRBG3 

IF  (JFULL.LT. 1  .OR.  JFULL. GT. 3)  GO  TO  II  AIRBG3 

IF  (JRESET- I )  13,13,14  BUTLER 1 

11  WRITE (6 ,12)  TIME  AIRBG3 

12  FORMAT  CO  ERROR  IN  SUBROUTINE  AIRBG3  AT  TIME  =’,F1O.0)  AIRBG3 

STOP  32  AIRBG3 

13  IF  ( JFULL-2)  41,49,49  BUTLER 1 

14  IF  (JFULL-2)  11,21,31  BUTLER 1 

C  AIRBG3 

C  END  OF  INTEGRATION  STEP  WHEN  IFULL=0.  TEST  FOR  FULL  INFLATION.  AIRBG3 

C  AIRBG3 

21  PD ( J )  ^0.0  AIRBG3 


66 


PCYV(J)  =  CYV(J)  AIRBG3 

PCYMIN(J)  =  CYMIN(J)  AIRBQ3 

PVBAQ(J)  =  VBAG(J)  AIBBG3 

22  CALL  AIBBGG(J)  AIRBG3 

VBAG(J)  =  CYV(J)  +  VOLBP(J)  AIRBG3 

IF  (SCALE ( J) .EQ. 1.0)  GO  TO  23  AIBBG3 

SCALE (J)  =  (VBAG( J) /VBAGG(J) ) #«THIRD  AIBBG3 

IF  (SCALE ( J) .LT. 1.0)  GO  TO  24  AIRBC3 

SCALE (J)  =1.0  AIRBG3 

GO  TO  22  AIBBG3 

23  IFULL(J)  =  -1  AIRBG3 

CYMOUT(J)  =0.0  AIRBG3 

PSW1  =  (VBAG  (J) -VBAGG(J) ) »PCYV (J) /PCYMIN(J)  AIBBG3 

PSW2  =  (VBAGG( J) -PVBAG(J) ) »  CYV(J)/  CYyiH(J)  AIBBG3 

SWITCH(J)  =  (PSW1+PSW2) / (VBAG(J) -PVBAG(J) )  AIRBG3 

BAGPV(J)  =  CYPA(J) * (CYMIN(J) *SWITCH(J) ) »«CYK(J)  AIBBG3 

PD ( J)  =  BAGPV ( J) / (CYV (J)»»CYK(J))  -  CYPA(J)  AIBBG3 

24  DO  25  K= 1 , 3  AIBBG3 

BD(K.JB)  =  SCALE (J)*Afi(K,J)  AIBBG3 

IF  (SCALE(J) .EQ.O.O)  GO  TO  25  AIBBG3 

BD (4«K+ 12 , JB)  =  BD(K.JB) »»2  AIRBG3 

BD(4*K+  3 , JB)  =  1.0/BD(4*K+12,JB)  AIBBG3 

25  TMP(K)  =  DEPLOY (K ,J)  ♦  BD( 1 , JB) »DPVCTB(K, J)  AIBBG3 

CALL  PANEL  (DBBd.l.J)  ,TMP,JB)  AIBBG3 

C  AIRBG3 

C  SET  UP  BAGSF  ARRAY  FOR  OUTPUT.  AIRBG3 

C  AIRBG3 

31  BAGSF ( 1 .NBGSF+1)  =  CYP(J)  AIRBG3 

BAGSF ( 2 , NBGSF  + 1 )  =  CYT(J)  AIRBG3 

BAGSF ( 3 , NBGSF  + 1 )  =  PD(J)  AIRBG3 

CALL  D0T31  (D( 1 , 1 . JB) ,BD (4 , JB) ,TMP)  AIRBG3 

DO  32  K= 1 , 3  AIRBG3 

BAGSF (K .NBGSF+3)  =  BD (K , JB)  AlRBG3 

32  TMP(K)  =  TMP(K)  +  SEGLP(K.JB)  -  SEGLP(K,NVEH)  AIRBG3 

CALL  MAT31  ( D ( 1 , 1 , NVEH) , TMP , BAGSF ( 1 , NBGSF + 2 ) )  AIRBG3 

CALL  YPRDEG  (D( 1 , 1 , JB) , BAGSF ( 1 , HBGSF+4) )  AIRBG3 

NBGSF  =  NBGSF  +  5  +  NPANEL(J)  +  MNBAG(J)  AIRBG3 

GO  TO  50  AIRBG3 

C  AIRBG3 

C  START  OF  INTEGRATION  STEP  WITH  IFULL  =  -1.  RESET  INTEGRATOR.  AIRBG3 

C  AIRBG3 

41  IFULL (J)  =  1  AIRBG3 

IRESET  =  -1  AIRBG3 

49  PYMOUT(J)  =  CYMOUT(J)  AIRBG3 

50  CONTINUE  AIRBG3 

CALL  ELTIME(2 ,29)  AIRBG3 

RETURN  AIRBG3 

END  AIRBG3 
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SUBROUTINE  BELTG  (ZA.ZB ,ZC , BD)  BELTG 

C  REV  IV  07/23/86TW0PI 

C  COMPUTE  TANGENT  POINTS,  UNIT  VECTORS  FROM  TANGENT  POINTS  TO  BELTG 

C  ANCHOR  POINTS  AND  LENGTHS  OF  THE  BELT  SEGMENTS.  BELTG 

C  BELTG 

C  ARGUMENTS :  BELTG 

C  BELTG 

C  ZA.ZB  -  ANCHOR  POINTS  RELATIVE  TO  ELLIPSOID  CENTER.  BELTG 

C  ZC  -  FIXED  POINT  OF  BELT  ON  SEGMENT  ELLIPSOID.  BELTG 

C  BD  SEGMENT  ELLIPSOID  SEMIAXES  AND  CENTER.  BELTG 

C  BELTG 

C  RESULTS  ARE  RETURNED  TO  CALLING  ROUTINE  VIA  COMMON/TEMPVS/ .  BELTG 

C  BELTG 

IMPLICIT  REAL *8  (A-H.O-Z)  BELTG 

DIMENSION  ZA(3) ,ZB(3) ,ZC(3) ,BD(24)  BELTG 

COMMON/CONTRL/  T I ME , NSEG , N JNT . NPL , NBLT , NBAG , NVEH , NGRND ,  BELTG 

«  NS , NQ , NSD , NFLX , NHRNS S , NWI NDF , NJNTF , NPRT ( 36 ) , NPG  PAGE 

COMMON/CNSNTS/  PI .RADIAN.G, THIRD , EPS (24) ,  BELTG 

*  UNITL,UNITM,UNITTtGRAVTY(3) .TWOPI  TWOPI 

C  NOTE:  BELTRT  AND  BELTG  SHARE  FIRST  PART  OF  TEMPVS  BELTG 

COMMON/TEMPVS/  APA(3) ,UVA(3) ,DLGA,UAA,APB(3) ,UVB(3) .DLGB.UBB  BELTG 

*  ,TA(3) ,TB(3) ,TC(3) ,UP(3) ,B(3)  BELTG 

«  ,UC(3) ,AX(3) ,XE(3) ,BX(3) ,ACA(3) ,ACB(3)  BELTG 

C  BELTG 

C  COMPUTE  BELTG 

C  TC:  NORMALIZED  VECTOR  OF  BELT  PLANE  DETERMINED  BELTG 

C  BY  ANCHOR  POINTS  AND  FIXED  POINT.  BELTG 

C  BELTG 

DO  10  K= 1 , 3  BELTG 

TA(K)  =  ZC(K)-ZA(K)  BELTG 

10  TB (K)  =  ZC (K) -ZB (K)  BELTG 

CALL  CROSS (TB.TA.TC)  BELTG 

S  =  DSQRT (TC ( 1) **2  ♦  TC(2)*»2  ♦  TC (3) **2)  BELTG 

TC ( 1 )  =  TC(1)/S  BELTG 

TC (2)  =  TC(2)/S  BELTG 

TC (3)  =  TC(3)/S  BELTG 

C  BELTG 

C  GET  DISTANCE  OF  BELT  PLANE  TO  CENTER  OF  ELLIPSIOD.  BELTG 

C  BELTG 

BET  =  TC ( 1 ) »ZC (1) +TC (2) «ZC (2) +TC (3) »ZC (3)  BELTG 

C  BELTG 

C  COMPUTE  BELTG 

C  XE:  CENTER  OF  ELLIPSE  DETERMINED  BY  INTERSECTION  BELTG 

C  OF  BELT  PLANE  AND  SEGMENT  ELLIPSOID.  BELTG 

C  BELTG 

CALL  MAT31  ( BD (16) ,TC ,XE)  BELTG 

GG  =  BET/ (TC ( 1) »XE ( 1 ) +TC (2) »XE (2) +TC (3) »XE (3) )  BELTG 

DLGA  =  0.0  BELTG 

DLGB  =  0.0  BELTG 

DO  15  K= 1 , 3  BELTG 
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BELTG 

BELTG 

BELTG 

BELTG 

BELTG 

BELTG 

BELTG 

BELTG 
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C  ACA.ACB:  VECTORS  FROM  UVA.UVB  TO  TANGENT  POIMTS  (POSITIVE).  BELTG 

C  BELTG 

CALL  MAT31  (BD(7) .ZA.AX)  BELTG 

CALL  MAT31  (BD(7) ,ZB,BX)  BELTG 

ZZA  =  AX( 1) «ZA( 1) +AX(2) *ZA(2) +AX(3) *ZA(3)  BELTG 

IF (  ZZA. LE. 1.0)  STOP  88  CHGIII 

ZZB  =  BX( 1) *ZB( 1) +BX(2) »ZB (2) +BX(3) *ZB (3)  BELTG 

IF (  ZZB. LE. 1.0)  STOP  89  CHGIII 

C2A  =  YAY1/ (ZZA-YAY)  BELTG 

C2B  =  YAY1/ (ZZB-YAY)  BELTG 

CALL  CROSS (TC, AX. ACA)  BELTG 

CALL  CROSS (TC.BX.ACB)  BELTG 

TTA  =  0.0  BELTG 

TTB  =  0.0  BELTG 

DO  21  1=1,3  BELTG 

DO  21  J= 1 . 3  BELTG 

K  =  3«J+I+3  BELTG 

TTA  =  TTA  ♦  ACA(I) *BD(K) *ACA(J)  BELTG 

21  TTB  =  TTB  ♦  ACB(I) «BD(K) »ACB(J)  BELTG 

C3A  =  DSQRT ((1.0  -  C2A) *YAY1/TTA)  CHGIII 

C3B  =  DSQRT ((1.0  -  C2B) «YAY1/TTB)  CHGIII 

TT  =  DSQRT(UC(1) »»2  ♦  UC(2)»»2  +  UC (3) «*2)  BELTG 

DO  24  K= 1 ,3  BELTG 

UVA(K)  =  C2A*(ZA(K)-XE(K))  BELTG 

UVB(K)  =  C2B* (ZB(K) -XE(K) )  BELTG 

ACA(K)  =  C3A»ACA(K)  BELTG 

ACB(K)  =  C3B»ACB(K)  BELTS 

UC (K)  =  UC (K) /TT  BELTG 

24  B (K)  =  0.0  BELTG 

C  BELTS 

C  OBTAIN  EQUATION  OF  ELLIPSE  BELTG 

C  B1*X**2  ♦  2*B2*X»Y  ♦  B3»Y»»2  =  1  BELTG 

C  IN  UC.UP  COORDINATES  WHERE  UC  POINTS  TO  FIXED  POINT.  BELTG 

C  BELTG 

CALL  CROSS (TC. UC.UP)  BELTG 

DO  22  1=1,3  BELTG 


XE(X)  =  XE (K) *GG 
UC (K)  =  ZC (K) -XE(K) 

APA(K)  =  UC (K) 

15  APB(K)  =  UC (K) 

YAY  =  GG»BET 
YAY1  =  1.0-YAY 
IF  (YAY1.LE.EPS (6) )  GO  TO  70 
C 

C  CALCULATE  POSSIBLE  TANGENT  POINTS  FROM 
C  UVA.UVB:  VECTORS  FROM  ELLIPSE  CENTER  TO  MIDPOINT  OF 

C  LINE  CONNECTING  POSSIBLE  TANGENT  POINTS. 


DO  22  J=1 ,3 
K  =  3*J+I+3 
B  ( 1 )  =  B  ( 1 ) 


+  UC ( I) *BD (K) *UC (J) 


BELTG 

BELTG 

BELTG 
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B (2)  =  B (2)  +  UC(I) »BD(K) *UP(J)  BELTQ 

22  B (3)  =  B (3)  ♦  UP ( I ) »BD (K) » UP ( J )  BELTQ 

B ( 1 )  =  B ( 1 ) /YAY1  BELTQ 

B(2)  =  B(2) /YAY1  BELTG 

B(3)  =  B(3) /YAY1  BELTG 

BELTG 

COMPUTE  ANGLES  FROM  FIXED  POINT  TO  POSSIBLE  TANGENT  POINTS.  BELTG 

BELTG 

UCUVA  =  UC ( 1) «UVA( 1 )  ♦  UC (2) «UVA(2)  +  UC(3)*UVA(3)  BELTG 

UCUVB  =  UC ( 1) *UVB( 1)  +  UC (2) *UVB (2)  ♦  UC(3)«UVB(3)  BELTG 

UCACA  *  UC ( I) »ACA( 1 )  ♦  UC(2)*ACA(2)  ♦  UC(3)*ACA(3)  BELTG 

UCACB  *  UC ( 1) »ACB ( 1)  +  UC(2)«ACB(2)  ♦  UC(3)*ACB(3)  BELTG 

UPUVA  =  UP ( 1) «UVA( 1)  ♦  UP(2) »UVA(2)  ♦  UP(3)«UVA(3)  BELTG 

UPUVB  =  UP( 1) *UVB( 1)  +  UP (2) »UVB (2)  +  UP(3)«UVB(3)  BELTG 

UPACA  =  UP ( 1) »ACA( 1 )  +  UP (2) «ACA(2)  ♦  UP(3)*ACA(3)  BELTG 

UPACB  =  UP ( 1 ) * ACB ( 1 )  +  UP (2) *ACB (2)  +  UP(3)«ACB(3)  BELTG 

TH1  =  DATAN2( UPUVA- UP ACA.UCUVA-UCACA)  BELTG 

TH2  =  DATAN2 (UPUVA+UPACA , UCUVA+UCACA)  BELTG 

TH3  =  DATAN2 ( UPUVB-UPACB , UCUVB-UCACB)  BELTG 

TH4  =  DATAN2 (UPUVB+UPACB , UCUVB+UCACB)  BELTG 

IF  (THI.LT.O.O)  TH1  =  TWOPI  +  THI  BELTG 

IF  (TH2.LT. O.O)  TH2  =  TWOPI  ♦  TH2  BELTG 

IF  (TH3.LT. 0.0)  TH3  =  TWOPI  ♦  TH3  BELTG 

IF  (TH4.LT. 0.0)  TH4  =  TWOPI  +  TH4  BELTG 

BELTG 

CHOOSE  PROPER  TANGENT  POINTS  AND  BELT  ARC  LENGTHS.  BELTG 

BELTG 

THMIN  =  DMIN1 (THI , TH2 , TH3 , TH4 )  BELTG 

IF  (THMIN. EQ. THI. AND. DMIN1 (TH2.TH3, TH4) .NE.TH4)  GO  TO  61  BELTG 

IF  (THMIN. EQ.TH2. AND. DMAX1 (THI, TH3, TH4) .EQ.TH4)  GO  TO  61  BELTG 

IF  (THMIN. EQ.TH3. AND. DMINKTH1, TH2, TH4)  .NE.TH2)  GO  TO  63  BELTG 

IF  (THMIN. EQ.TH4. AND. DMAX1 (THI, TH2.TH3) .EQ.TH2)  GO  TO  63  BELTG 

GO  TO  70  BELTG 

61  THA  =  THI  BELTG 

THB  =  TWOPI -TH4  BELTG 

DO  62  K= 1 , 3  BELTG 

APA(K)  =  UVA(K) -ACA(K)  BELTG 

62  APB(K)  =  UVB(K) +ACB(K)  BELTG 

GO  TO  65  BELTG 

63  THA  =  TWOPI -TH2  BELTG 

THB  =  TH3  BELTG 

DO  64  K=1 ,3  BELTG 

APA(K)  =  UVA (K) +ACA (K)  BELTG 

64  APB (K)  =  UVB(K) -ACB(K)  BELTG 

65  CONTINUE  BELTG 

EPS1  =  EPS(l)  BELTG 

DLGA  =  DABS (ELONG(B ( 1 ) ,B(2) ,B(3) ,EPS1 ,THA) )  BELTG 

DLGB  =  DABS(ELONG(B( 1) ,B(2) ,B(3) ,EPS1 ,THB) )  BELTG 

BELTG 

CALCULATE  BELT  LENGTHS  AND  UNIT  VECTORS  BELTG 


FROM  TANGENT  POINTS  TO  ANCHOR  POINTS. 


C 
C 

70  UAA=0. 

UBB=0 . 

DO  80  K=1 ,3 

APA(K)  =  APA(K) +XE (K) 

APB (K)  =  APB(K) +XE(K) 

UVA(K) =ZA(K) -APA(K) 

UVB(K) =ZB(K) -APB(K) 

APA(K) -APA(K) +BD(K+3) 

APB(K) ®APB(K) +BD(K+3) 
OAA=UAA+DVA(K) **2 
UBB=UBB«-UVB (K) »*2 
80  CONTINUE 

UAAsDSQRT (UAA) 

UBB=DSQRT (UBB) 

DO  90  K=1 ,3 
UTA(K) =UVA(K) /UAA 
UVB(K) =UTB(K) /UBB 
90  CONTINUE 
C 

C  OPTIONAL  OUTPUT 
C 

IF  ( NPRT (15) . EQ . 0 )  GO  TO  99 
WRITE(6,50) 

50  FORMAT (IK, ’BELT  RESTRAINT’) 
WRITE (6 ,60)  APA , UVA , DLGA , UAA 
WRITE(6,60)  APB , UVB , DLGB , UBB 
60  FORMAT  ( IX, IP8D15 . 5) 

99  CONTINUE 
RETURN 
END 
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SUBROUTINE  BELTRT (I, II, MM, M, NT)  BELTRT 

REV  IV  07/23/86TW0PI 

THE  ROUTINE  CALLS  SUBROUTINE  BELTG  TO  COMPUTE  THE  TANGENT  POINTS  BELTRT 
AND  BELT  LENGTHS  AND  APPLIES  THE  RESTRAINT  FORCES  TO  THE  U1  ARRAY  BELTRT 
AND  BELT  TORQUES  TO  THE  U2  ARRAY  FOR  ELLIPSOID (II)  ATTACHED  TO  BELTRT 
BODY  SEGMENT  (I)  BY  BELT  (M)  ATTACHED  TO  SEGMENT  (MM).  BELTRT 

BELTRT 

IMPLICIT  REAL»8(A-H,0-Z)  BELTRT 

COMMON/CONTRL/  TIME , NSEG , NJNT , NPL , NBLT , NBAG , NVEH , NGRND ,  BELTRT 

»  NS , NQ , NSD , NFLX , NHRNSS , NWINDF , NJNTF , NPRT ( 36 ) , NPG  PAGE 

COMMON/ SGMNTS/  D(3,3,30) ,WMEG(3,30) ,WMEGD(3 .30) ,UI(3,30) ,U2(3,30) .BELTRT 
ft  SEGLP(3,30) ,SEGLV(3,30) ,SEGLA(3,30) ,NSYM(30)  BELTRT 

COMMON/CNTSRF /  PL(24,30) .BELT(20,8) ,TPTS(6,8) ,BD(24,40)  EDGE 

COMMON/ TABLES /MXNT I .MXNTB.MXTBl .MXTB2 ,NTI (50) ,NTAB(1250) ,TAB(4500)DIMENB 
COMMON/FORCES/PSF(7 ,70) ,BSF(4,20) ,SSF(10,40) ,BAGSF(3,20) ,  NCFORC 

*  PRJNT(7.30) ,NPANEL(5) , NPSF . NBSF , NSSF , NBGSF  BELTRT 

COMMON/CNSNTS/  PI .RADIAN, G. THIRD, EPS(24) ,  BELTRT 

«  UNITL,UNITM,UNITT,GRAVTY(3) .TWOPI  TWOPI 

COMMON/RSAVE/  XSG(3 , 20 , 3) .DPMI (3 ,3 ,30) ,LPMI  (30) ,  TGMOD4 

«  NSG(9) ,MSG(20,9) ,MCG,MCGIN(24 ,5) ,KREF(20,9)  TTHKREF 

NOTE:  BELTRT  AND  BELTG  SHARE  FIRST  PART  OF  TEMPVS  BELTRT 

COMMON/TEMPVS/  APA(3) ,UVA(3) , DLGA.UAA, APB(3) ,UVB(3) , DLGB.UBB  BELTRT 

DIMENSION  TA(3) ,TB(3) ,ZA(3) ,ZB(3) ,TT(3) ,TTT(3) ,TA1(3) ,TB1(3)  TGM0D4 

BELTRT 

CALL  ELTIME ( 1 , 22)  BELTRT 

BELTRT 

CONVERT  SEGMENT  POSITION  TO  SEGMENT  REFERENCE.  BELTRT 

BELTRT 

MA  =  MOD (MM, 100)  JTF984 

MB  =  MM/ 100  JTF984 

IF  (MB.EQ.O)  MB=MA  JTF984 

CALL  DOT31  (D ( 1 , 1 ,MA) ,BELT( 1 ,M) ,TA)  BELTRT 

CALL  D0T31  (D ( 1 , 1 ,MB) .BELT (4 ,M) ,TB)  BELTRT 

DO  10  K= 1 ,3  BELTRT 

TA(K)  =  SEGLP(K.MA)  +  TA(K)  -  SEGLP(K.I)  BELTRT 

10  TB (K)  =  SEGLP(K.MB)  +  TBiK)  -  SEGLP(K,I)  BELTRT 

CALL  MAT31  (D ( 1 , 1 , I) ,TA,ZA)  BELTRT 

CALL  MAT31  (D( 1 , 1 , I) ,TB ,ZB)  BELTRT 

DO  13  K*l,3  BELTRT 

ZA(K)  =  ZA(K)  -  BD (K+3 , II)  BELTRT 

13  ZB (K)  =  ZB (K)  -  BD (K+3 ,11)  BELTRT 

C  BELTRT 

C  COMPUTE  NEW  BELT  LENGTHS  AND  EXPANSION.  BELTRT 

C  BELTRT 

CALL  BELTG  (ZA,  ZB,  BELT (7, M),  BD (1,11))  BELTRT 

TLA  =  DLGA+UAA  BELTRT 

TLB  =  DLGB+UBB  BELTRT 

TL  =  TLA+TLB  BELTRT 

IF  (TIME. NE. 0.0)  GO  TO  11  BELTRT 

C  BELTRT 
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IF  TIME-0 ,  COMPUTE  INITIAL  BELT  LENGTHS  BELTBT 

AND  STORE  RESULTS  IN  BELT  ARRAT.  BELTRT 

BELTBT 

IF  (BELT(ll.M) .LT.0.0)  BELT(11,M)=  -BELT ( 1 1 , M) -TL  BELTRT 

IF  (BELT(ll.M) .LT.0.0)  BELT ( 1 1 ,M) =0 . 0  BELTRT 

BELT ( 1 2 , M)  =  TLA+TLA/TL*BELT ( 1 1 ,M)  BELTRT 

BELT ( 13, M)  =  TLB+TLB/TL»BELT ( 1 1 , M)  BELTRT 

B1213  =  BELT ( 1 2 , M)  ♦  BELT ( 1 3 ,  M)  BELTRT 

BELT ( 10, M)  =  B1213  BELTRT 

DO  305  LL= 1 ,3  TGM0D4 

TAKLL)  =  APA(LL)  TGM0D4 

305  TBKLL)  =  APB(LL)  TGM0D4 

IF(LPMI(I) .EQ.O)  GO  TO  306  TGM0D4 

CALL  DOT3 1 ( DPMI (1,1,1), APA , TA1 )  TGM0D4 

CALL  D0T31 (DPMI  (1,1,1) .APB.TBl)  TGM0D4 

306  CONTINUE  TGM0D4 

WRITE  (6,14)  M,  B 1 2 1 3 ,  BELT(12,M) ,  BELT ( 13, M) ,  UNITL.I.TA1,  TB1  TGM0D4 

14  FORMAT ( ' 0  INITIAL  LENGTHS  OF  BELT  NO.’, I 3,*  AND  ITS  SEGMENTS  ARE’ .BELTRT 
«  3F12 . 4 , IX, A4/ ' 0  INITIAL  TANGENT  POINTS  IN  LOCAL  REFERENCE  TGM0D4 

•OF  SEGMENT  ’,12,’  ARE: ’ , / , 2 (3X.3F12. 3) )  TGM0D4 

BELTRT 

CONVERT  TANGENT  POINTS  TO  INERTIAL  REFERENCE  AND  STORE.  BELTRT 

BELTRT 

11  CALL  D0T31  (D( 1 , 1 , I) , APA.TPTS ( 1 ,M) )  BELTRT 

CALL  D0T31  (D( 1 , 1 , 1) , APB.TPTS (4 ,M) )  BELTRT 

DO  12  K=1 ,3  BELTRT 

TPTS (K  , M)  *  TPTS (K  ,M)  +  SEGLP(K.I)  BELTRT 

12  TPTS (K+3 ,M)  =  TPTS(K+3,M)  ♦  SEGLP(K.I)  BELTRT 

SDOT  =0.0  BELTRT 

NCF  =  NTAB (NT+5)  BELTRT 

IF  (NCF.NE.O)  GO  TO  15  BELTRT 

BELTRT 

ZERO  BELT  FRICTION,  COMPUTE  STRAIN  AND  FORCE  OF  ENTIRE  BELT.  BELTRT 

BELTRT 

B1213  =  BELT ( 12 ,M) +BELT (13, M)  BELTRT 

S  =  (TL-B12131/B1213  BELTRT 

SA  =  S  BELTRT 

SB  =  S  BELTBT 

IF  (S. LT.0.0)  S  =  0.0  BELTBT 

CALL  FRCDFL  (S , SDOT, NT, 1 , FA.ELOSS)  BELTBT 

FB  =  FA  BELTRT 

GO  TO  17  BELTRT 

BELTRT 

FULL  BELT  FRICTION,  COMPUTE  STRAIN  AND  FORCE  OF  EACH  PART  OF  BELT. BELTRT 

BELTBT 

15  IF  (TL .GT.BELT ( 10 ,M) )  GO  TO  16  BELTRT 

FA  =  0.0  BELTRT 

FB  =  0.0  BELTBT 

SA  =  (TL-BELT (10, M) ) /BELT ( 10 ,M)  BELTBT 

SB  =  SA  BELTRT 


BELT  (12 ,11)  =  TLA  BELTBT 

BELT  (13,11)  =  TLB  BELTBT 

GO  TO  17  BELTBT 

16  S  =  (TLA-BELT (12, M) ) /BELT ( 12 ,M)  BELTBT 

SA  =  S  BELTBT 

IF  (S.LT.O.O)  S  =  0.0  BELTBT 

CALL  FBCDFL  (S.SDOT.NT, 1 .FA.ELOSS)  BELTBT 

S  =  (TLB-BELT ( 1 3, M) ) /BELT (13,11)  BELTBT 

SB  =  S  BELTBT 

IF  (S.LT.O.O)  S  =  0.0  BELTBT 

CALL  FBCDFL  (S ,SDOT ,NT+6 , 1 ,FB .ELOSS)  BELTBT 

BELT ( 10, M)  =0.0  BELTBT 

17  BSF(l.NBSF)  =  SA  BELTBT 

BSF(2,NBSF)  =  FA  BELTBT 

BSF(3,NBSF)  =  SB  BELTBT 

BSF(4 ,NBSF)  =  FB  BELTBT 

IF  (FA+FB.LE.O.O)  GO  TO  31  BELTBT 

BELTBT 

COMPOTE  FOBCE  VECTOBS.  BELTBT 

BELTBT 

DO  20  K=1 ,3  BELTBT 

UVA  (K)  =  FA*OVA(K)  BELTBT 

20  UVB(K)  =  FB*UVB(X)  BELTBT 

BELTBT 

CONVEBT  FOBCES  TO  INEBTIAL  BEFEBENCE  AND  ADD  TO  01  ABBAY.  BELTBT 

BELTBT 

CALL  D0T31 (D( 1 , 1 , I ) ,OVA,TT  )  BELTBT 

CALL  D0T31 (D ( 1 , 1 , I ) , OVB.TTT)  BELTBT 

DO  30  K=1 ,3  BELTBT 

01(K,MA)  =  01(K,MA)  -  TT(K)  JTF984 

Ol(K.MB)  =  01(K,MB)  -  TTT(K)  JTF984 

30  01 (K. I)  =  01 (K, I) +TTT(K)  +  TT(K)  JTF984 

BELTBT 

CONVEBT  TOBQOES  TO  LOCAL  BEFEBENCE  AND  ADD  TO  02  ABBAY.  BELTBT 

BELTBT 

CALL  MAT31(D( 1,1, MA) ,TT,ZA)  JTF984 

CALL  MAT31 (D(l , 1 ,MB) ,TTT,ZB)  JTF984 

CALL  CB0SS(BELT(1,M) ,ZA,TA)  JTF984 

CALL  CBOSS (BELT(4 ,M) ,ZB,TB)  JTF984 

CALL  CBOSS (APA, OVA, TT)  BELTBT 

CALL  CBOSS ( APB, OVB.TTT)  BELTBT 

DO  40  K=1 ,3  BELTBT 

02(K,MA)  =  02 (K ,MA)  -  TA(K)  JTF984 

02(K,MB)  =  02(K,MB)  -  TB(K)  JTF984 

40  02 (K, I)  =  02 (K , I ) + (TT(K) +TTT (K) )  BELTBT 

31  CONTI NOE  BELTBT 

CALL  ELTIME(2,22)  BELTBT 

BETOBN  BELTBT 

END  BELTBT 
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SU6B0UTIME  BGG ( A , ZA , DA , BFA , VA , WA ,  BGG 
i  B , ZB , DB , BFB , VB , WB ,  BOG 
*  VSC  S , I FULL , T V , FBA , TOBQ , TQB , VOL )  BGG 

BEV  IV  07/23/86TW0PI 

COMPUTES  THE  VOLUME  OF  INTERSECTION  OF  AH  ELLIPSOIDAL  AIBBAG  BGG 
WITH  AH  ELLIPSOIDAL  BODY  SEGMENT  OB  BEACTIOH  PAHEL.  BGG 
ALSO  COMPUTES  THE  FOBCE  PEB  UNIT  PBESSUBE  AND  TORQUE  PEB  UHIT  BGG 
PRESSURE  OH  BOTH  THE  BAG  AHD  THE  IHTEBSECTIHG  OBJECT.  BGG 


ARGUMENTS: 
AIRBAG  INPUTS 


A(3,3)  -  ELLIPSOID  MATRIX 
ZAO)  -  C.G. 

DAO, 3)~  DIRECTION  COSINE  MATRIX 
BFAO)  -  OFFSET 

VAO)  -  CG  VELOCITY ( I HEBTIAL  REF.) 
WAO)  -  ANGULAR  VELOCITY  (LOCAL  REF.) 


CONTACT  SURFACE  B(3,3) 
ZB  (3) 

DB (3 ,3) 

BFB (3) 

VB<3) 

WB(3) 

VSCS 

I  FULL 

TV(3) 


ELLIPSOID  MATRIX 
C.G. 

DIRECTION  COSINE  MATRIX 
OFFSET 

CG  VELOCITY  (INERTIAL  REF.) 

ANGULAR  VELOCITY  (LOCAL  REF.) 
COEFFICIENT  OF  SLIDING  FRICTION 
IF  ZERO,  COMPUTE  VOL  ONLY. 

MEMORY  FOR  SUBROUTINES  INTERS  &  EDEPTH. 


OUTPUT  :  FRA (3)  -  FORCE  ON  BAG  BGG 

TORQ (3) -  TORQUE  ON  BAG  BGG 

TOB(3)  -  TORQUE  ON  CONTACT  SURFACE  BGG 

VOL  -  VOLUME  OF  INTERSECTION  BGG 

IMPLICIT  REAL*8  (A-H.O-Z)  BGG 

DIMENSION  A(3 ,3) ,ZA(3) ,DA(3,3) ,BFA(3) ,VA(3) ,WA(3) ,B(3,3) ,ZB(3) ,  BGG 
»  DB(3,3) ,BFB(3) ,VB(3) ,WB(3) ,FRA(3) ,TORQ(3) ,TQB(3) ,TV(3)  BGG 

COMMON/CNSNTS/  PI .RADIAN, G, THIRD , EPS (24) ,  BGG 

*  UNITL,UNITM,UNITT,GRAVTY(3) .TWOPI  TWOPI 

COMMON/TEMP  VS/  DUMMY(200)  ,DAB(3,3)  ,BA(3,4)  , TEMPO, 3)  ,Y(3)  ,CPA(3)  ,  BGG 

•  CPB(3) ,PLANE(4,3) .FORCE (3) ,CBB(3) ,VLM(3) ,FRB(3) ,  BGG 

»  YFA(3) ,YFB(3) ,ZBB(3) ,T1(3) ,T2(3) ,T3(3) ,T4 (3) ,T5(3) ,T6(3)  BGG 

NOTE:  DUMMY  IS  USED  BY  SUBROUTINES  AIRBAG  AND  AIRBGG.  BGG 

BGG 

INITIALIZATION  BGG 

BGG 

S3TEST  =10.0  BGG 

V0L=0 .  BGG 

DO  5  1=1,3  BGG 

FRA ( I )  =  0.0  BGG 

TORQ ( I )  =  0.0  BGG 

TQB  (I)  =  0.0  BGG 

BA(I ,4) = -BFA ( I )  BGG 


FRA ( 3 ) 
TORQ (3) 


mmmssm 


p 


DO  5  J=1 ,3  BOG 

BA(I ,4) =BA(I ,4) +DA(I , J) » (ZB(J) -ZA(J) )  BGG 

DAB (I , J) =0 .  BGG 

DO  5  K=1 ,3  BGG 

5  DAB (I , J) =DAB(I , J) +DA(I ,K) »DB(J , K)  BOG 

C  BGG 

C  COMPUTE  DISTANCE  BETWEEN  ELLIPSOID  CENTERS  AND  BGG 

C  CONVERT  ELLIPSOID  MATRIX  OF  OBJECT  TO  AIRBAG  REFERENCE.  BGG 

C  BGG 

DO  10  1*1,3  BGG 

DO  10  J=1 ,3  BGG 

TEMP(I.J)  =  0.0  BGG 

BA(I ,4) =BA(I ,4) +DAB(I , J) «BFB(J)  BGG 

DO  10  K=1 ,3  BGG 

10  TEMP (I ,J)  *  TEMP (I , J)  ♦  B ( I ,K) *DAB(J,K)  BGG 

CALL  MAT33(DAB,TEMP,BA)  BGG 

C  BGG 

C  CHECK  FOR  INTERSECTION  AND  DETERMINE  POINTS  OF  MAXIMUM  PENETRAT I ONBGG 
C  BGG 

TB  =  1.0  BGG 

CALL  INTERS  (A.BA.BAd  .4)  .TB.Y.TVd)  ,T1)  BGG 

IF  (TB.GT.1.0)  RETURN  BGG 

CALL  EDEPTH  (A,BA,BA( 1 ,4) ,TB,Y,CPA,CPB,TV(2) ,TV(3) )  BGG 

C  BGG 

C  SET  UP  ORTHOGONAL  SYSTEM  USING  VECTOR  BETWEEN  POINTS  BGG 

C  OF  MAXIMUM  PENETRATION  AS  ONE  AXIS.  BGG 

C  BGG 

P  =  0.  BGG 

DO  20  1=1,3  BGG 

PLANE (I ,3)  =  CPA(I) -CPB(I)  BGG 

20  P  =  PLANE d ,3) ««2+P  BGG 

IF  (P.LT.EPS(6) )  GO  TO  99  BGG 

PP  =  DSQRT(P)  BGG 

DO  25  1*1,3  BGG 

25  TEMP (1,1)  =  PLANE (I ,3) /PP  BGG 

CALL  ORTHO ( PLANE , TEMP , 4 )  BGG 

C  BGG 

C  DEFINE  PLANES  AT  MAXIMUM  PENETRATION  POINTS.  „  BGG 

C  BGG 

DO  40  1=1,3  BGG 

PLANE (4,1)  *  0.0  BGG 

DO  40  J* 1 , 3  BGG 

40  PLANE (4, I)  =  PLANE (4 , I ) +PLANE ( J , I) *CPB (J)  BGG 

DO  45  K= l , 3  BGG 

45  CBB (K) =CPB (K) -BA(K , 4)  BGG 

C  BGG 

C  ESTIMATES  OF  VOLUME  AND  AREA  BASED  ON  RADII  OF  CURVATURE  BGG 

C  AND  PENETRATION.  BGG 

C  BGG 


ABEA=PI 

DO  70  L=1 ,2 

RA=RCRT (A .PLANE .CPA , L) 

BB=BCBT (BA , PLANE , CBB , L) 

IF (PP . GT . BA) BA=PP 
B= (BA-BB) • . 5 
BC= (BA+BB) * . 5 
VP=PP/ (BA+BB) 

VD=VP 

ALP*RC»DSQBT(VP* (2. -VP) ) 

IF(R.GE.O. )G0  TO  60 
AB=BA+BB-PP 

BET= (RA#*2-BB*«2+AB*«2) « . 5/AB 
ALP=DSQRT(BA*»2-BET*«2) 

R=0 . 

VD= 1 . -BET/BA 
VP= (PP+BET-BA) /BB 

60  VLM(L) =BB* (RB«VP) **2« ( 1 . -VP/3 . ) +RA* (BA*VD) *»2* ( 1 . -VD/3 . ) 
IF (B.GT-.O. )  VLM(L)  =VLM(L)  -ALP«B«B«  (PI-2.  *  (DASIN(  1 .  -VP)  ♦ 

*  ( 1 . -VP) *ALP/BC) ) 

VLM(L) =VLM(L) »PI 
AREA=AREA*ALP 
70  IP=1 

VOL= (VLM( 1) +VLM(2) ) * .  5 
IF  (IFOLL.EQ.O)  00  TO  99 

SET  UP  FOBCE  VECTOB  ALONG  LINE  OF  MAXIMUM  PENETRATION. 

CALL  D0T3 1 ( DAB , CBB , ZBB ) 

DO  76  K=1 ,3 
YFA(K) =CPB(K) +BFA(K) 

YFB (K) =ZBB (K) +BFB (K) 

FOBCE (K)  =  -AREA»PLANE(X,3) 

76  Tl(K)  =  VA(K) -VB(K) 


COMPUTE  ANGULAR  VELOCITY  COMPONENTS .RELATIVE  VELOCITY,  COMPONENTS  BGG 
OF  RELATIVE  VELOCITY  ALONG  MAX  PENETRATION  LINE  AND  MAGNITUDE  OF  BGG 
FOBCE .  BGG 

BGG 

CALL  MAT31 (DA.Tl ,T2)  BGG 

CALL  CROSS (WA.YFA.Tl)  BGG 

CALL  CB0SS(WB,YFB,T3)  BGG 

CALL  MAT31 (DAB.T3.T4)  BGG 

FM  -  0.0  BGG 

SUM  =  0.0  BGG 

DO  77  K«l,3  BGG 

T5(K)  =  T2 (K) +T1 (K) -T4 (K)  BGG 

SUM  =  SUM+T5 (K) » PLANE (K , 3)  BGG 

77  FM  =  FM+F0RCE(K)»#2  BAG 


non 


COMPUTE  COMPONENTS  OF  RELATIVE  VELOCITY  IN  TANGENT  PLANE,  BGG 

FRICTION  FORCE  AND  TOTAL  FORCE  VECTOR.  BGG 

BGG 

S3  =  0.0  BGG 

DO  78  K=1 ,3  BGG 

T6(K)  =  T5(K) - SUM* PLANE (K, 3)  BGG 

78  S3  =  S3+T6 (K) »*2  BGG 

SQ3  =  DSQRT (S3)  BGG 

IF  (SQ3.LT. S3TEST)  SQ3=S3TEST/ (2.0-SQ3/S3TEST)  BGG 

FF  *  VSCS*DSQRT(FM)/SQ3  BGG 

DO  79  K-1,3  BGG 

79  FORCE(K)  =  FORCE (K) -FF«T6(K)  BGG 

C  BGG 

C  COMPUTE  FRB:  FORCE  ON  REACTION  SURFACE  IN  ITS  LOCAL  REFERENCE.  BGG 
C  TORQ;  TORQUE  ON  AIRBAG  IN  AIRBAG  REFERENCE.  BGG 

C  TQB:  TORQUE  ON  REACTION  SURFACE  IN  ITS  LOCAL  REFERENCE.  BGG 

C  FRA:  FORCE  ON  AIRBAG  IN  INERTIAL  REFERENCE.  BGG 

C  BGG 

CALL  DOT3I (DAB .FORCE, FRB)  BGG 

CALL  CROSS (YFA, FORCE, TORQ)  BGG 

CALL  CROSS ( FRB, YFB, TQB)  BGG 

CALL  DOT31( DA, FORCE, FRA)  BGG 

99  RETURN  BGG 

END  BGG 
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SUBROUTINE  B INPUT 


REV  IV 


B INPUT 

07/24/86SLIP 


READS  THE  INPUT  CARDS  THAT  CONTAINS  THE  PHYSICAL  DIMENSIONS  AND 
CHARACTERISTICS  OF  THE  CRASH  VICTIM’S  BODY  SEGMENTS  AND  JOINTS. 

IMPLICIT  REAL*8 (A-H.O-Z) 

COMMON/CONTRL/  TIME , NSEG , NJNT , NPL , NBLT . NBAG , NVEH . NGRND , 

*  NS , NQ , NSD , NFLX , NHRNSS , NWINDF , N JNTF , NPRT ( 36 ) ,NPG 
COMMON/ DESCRP/  PHK3.30)  ,W(30)  ,RW(30)  ,SR(4,60)  ,HA(3,60)  ,HB(3,60) 

»  RPHI (3,30) ,HT (3 , 3,60) ,SPRING(5,90) ,VISC(7,90) , 

»  JNT (30) , I P I N ( 30 ) ,ISING(30) ,IGL0B(30) ,JOINTF(30) 

COMMON/ CNTSRF/  PL(24,30) ,BELT(20,8) ,TPTS(6,8) ,BD(24,40) 
COMMON/TITLES/  DATE ( 3 ) ,C0MENT(40) ,VPSTTL(20) ,BDYTTL(5) . 

*  BLTTTL(5 ,8) ,PLTTL(5,30) , BAGTTL (5,6) ,SEG(30) . 

»  J0INT(30) ,CGS(30) ,JS(30) 

REAL  DATE . COMENT . VPSTTL , BDYTTL , BLTTTL , PLTTL , BAGTTL , SEG . JO I NT 
LOGICAL* 1  CGS.JS 

COMMON/ INTEST/  SGTEST (3 , 4 , 30) ,XTEST(3, 120) ,SEGT(120) ,REGT(120) 
REAL  SEGT 

COMMON/ FLXBLE/  HF(4,12,8) ,B42(3.3,24) ,V4(3,8) ,NFLEX(3,8) 
COMMON/CEULER/  IEULER(30) ,HIR(3,3,90) ,ANG(3.30) ,ANGD(3,30) . 

»  FE(3,30) ,TQE(3,30) ,C0NST(5,30) 

COMMON/CNSNTS/  PI .RADIAN.G, THIRD, EPS(24) , 

»  UNITL.UNITM,UNITT,GRAVTY(3) .TWOPI 

COMMON/RSAVE/  XSG(3.20,3) .DPMI (3,3,30) ,LPMI (30) . 

*  NSG(9) , MSG (20 ,9) ,MCG,MCGIN(24,5) ,KREF(20,9) 
LOGICAL* 1  EULER .SLIP 

COMMON/TEMPVS/  YPRK3.30)  ,YPR2(3,30)  ,YPR3(3,30)  , YPRPMI  (3 , 30)  , 

*  Tl(6) ,TMP1 (3,3) ,TMP2(3,3) ,KNT(30) ,IDYPR(6,30) , 

*  EULER (30) 

DATA  MXNSEG/30/ , MXNJNT/30/ , MNFLX/8/ 

CALL  ELTIME(1,  2) 

IDYPRT  =  0 

INPUT  CARD  B.l 

READ  (5,11)  NSEG, NJNT, BDYTTL 
11  FORMAT  (2I6.8X.5A4) 

IF  (NSEG.GT.MXNSEG)  STOP  77 
IF  ( NJNT . GT . MXNJNT )  STOP  78 

INPUT  CARDS  B.2.I  FOR  EACH  SEGMENT. 

DO  12  1=1, NSEG 

READ  (5,13)  SEG(I) , CGS (I) ,  W(I) , (PHI (J,I) , J= 1 ,3) , 

*  (BD(J.I) ,J=1,6) ,LPMI(I) 

13  FORMAT (A4 , 1X,A1,10F6.0,I4) 

DO  81  J=1 ,3 

IDYPR(J.I)  =  4-J 
81  YPRPMI (J, I)  =0.0 
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IF  (LPMI(I) . EQ. 0)  GO  TO  12 
READ  (5,82)  (YPRPMI (J , I) , J= 1 , 3) 

82  FORMAT (12X.3F6.0) 

12  CALL  DRCYPR  (DPMI ( 1 . 1 , I) , YPRPMI ( 1 , I) . IDYPR( 1 , I) ) 


INPOT  CARDS  B.3.J  FOR  EACH  JOINT. 


NFLX  =  0 

IF  (NJNT.EQ.O)  GO  TO  27 
SLIP  =  .FALSE. 

DO  14  J= 1 , NJNT 

BEAD  (5,15)  JOINT (J) , JS (J) , JNT (J) , IP1N(J) , (SR(I , 2«J-1) ,1=1,3) , 

*  (SR(I,2*J) ,1=1.3) , IEULER(J) ,CONST(l,J) ,CONST(2,J) . 

*  (YPRl(I.J) .1=1,3) , (YPR2 (I , J) .1=1,3) , 

*  (YPR3(I,J) ,1=1,3) .(IDYPR(I.J) .1=1,6) 

ID1  =  IDYPR(l.J) 

ID4  =  IDYPR(4 , J) 

EULER (J)  =  .FALSE. 

IF  (IPIN(J) .EQ.4)  EULER (J)  =  .TRUE. 

IF  (IEULER(J) .EQ.O.AND.IPIN(J) .LE.-4)  EULEB(J)  =  .TRUE. 

IF  (.NOT. EULER (J) . AND. IABS(IPIN(J) ) .GE.5)  SLIP  =  .TRUE. 

IF (ID1 .NE. 0 .OR. ID4 .NE.O)  IDYPRT  =  1 
DO  479  11=1,6 

479  IF(IABS(IDYPR(II ,J) ) .GT.3)  STOP  101 
DO  14  1=1,3 

IF  (ID1.EQ.O)  IDYPR(I  ,J)  =  4-1 

14  IF  (ID4.EQ.0)  IDYPR(I+3, J)  =  4-1 

15  FORMAT (A4, IX. A1 , 214, 6F6.0, 14, 2F6 . 0/ 14X.9F6 . 0,612) 


COMPUTE  NFLX  AND  NFLEX  ARRAY  FROM  NEGATIVE  VALDES  OF  JNT(J). 

NFLX  WILL  BE  NUMBER  OF  CONSTRAINT  TORQUES  FOR  FLEXIBLE  SEGMENTS. 
NFLEX ( 1 ,  )  REFERENCE  SEGMENT  (LOWEST  NUMBERED  SEGMENT  OF  CHAIN) 
NFLEX (2,  )  INTERIOR  SEGMENT  NUMBERS 

NFLEX (3 ,  )  TERMINATING  SEGMENT  (HIGHEST  NUMBERED  SEGMENT  IN  CHAIN) 
VALUES  OF  NFLEX  NEED  NOT  BE  SEQUENTIAL  BUT  MUST  BE  ORDERED. 
FLEXIBLE  SEGMENT  MUST  BE  SIMPLE  CHAIN,  I.E.,  BRANCHING  SEGMENTS 
CANNOT  BE  ATTACHED  TO  INTERIOR  SEGMENTS  BUT  MAY  BE  ATTACHED  TO 
REFERENCE  OR  TERMINATING  SEGMENTS. 


DO  16  J= 1 , NJNT 
16  KNT(J)  =  JNT(J) 

DO  22  J= 1 , NJNT 
IF  (KNT(J) . GE . 0 )  GO  TO  22 
NFA  =  NFLX+1 
IT  =  J*1 

IF  (IT. GT. NJNT)  GO  TO  18 
JP1  =  J+l 

DO  17  L=JP1 , NJNT 
IF  (IABS(KNT(L)) .NE.IT)  GO  TO  17 
KL  =  KNT(L) 
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KNT(L)  =  0 

IF  (KL.GT.O)  GO  TO  18 
NFLX  =  NFLX+1 

NFLEX(1 ,HFLX)  =  IAPS(KNT(J)) 

NFLEX ( 2 , NFLX)  =  IT 
IT  =  L+l 

17  CONTINUE 

18  IF  (NFLX.GE.NFA)  GO  TO  20 
WRITE  (6,19) 

19  FORMAT (’OERROR  IN  DEFINING  FLEXIBLE  SEGMENTS,  ONLY  ONE  NEGATIVE 
»T  IN  STRING.  PROGRAM  TERMINATED.’) 

STOP  3 

20  DO  21  K=NFA,NFLX 

21  NFLEX(3.K>  =  IT 

22  CONTINUE 

INPUT  CARDS  B.4.J  FOR  EACH  JOINT. 

DO  23  J= 1 , NJNT 

READ  (5,24)  (SPRING (I ,3«J-2) ,1=1,5) , (SPRING (I ,3*J-1) ,1=1,5) 

23  IF  (EULER(J))  READ (5 ,24) (SPRING (I ,3*J) ,1=1,5) , (ANG(I , J) , 1=1 ,3) 

24  FORMAT ( 2 (4F6. 0, F12. 0)  ) 

INPUT  CARDS  B.5.J  FOB  EACH  JOINT. 

DO  25  J= 1 ,NJNT 

READ  (5,28)  (VISC (I , 3»J-2) , 1  = 1 , 7) 

IF  (.NOT. EULER (J))  GO  TO  25 
READ  (5,26)  (VISC (I ,3*J-1) ,1*1 .7) 

READ  (5,26)  (VISC(I,3*J  ), 1=1,7) 

25  CONTINUE 

26  FORMAT (5F6 . 0 , 18X.2F6.0) 

INPUT  CARDS  B.6.I  FOR  EACH  SEGMENT. 

27  DO  28  1=1 ,NSEG 

29  READ  (5,29)  ( (SGTEST ( J ,K, I) , J=1 ,3) ,K=1,4) 

29  FORMAT (12F6.0) 

PRINT  CARD  B.l 

WRITE  (6,30)  BDYTTL , NSEG , NJNT , NPG , UNITM, UNITT , UNITL , UNITL , 

»  UNITL. UNITM 

NPG=NPG*1 

30  FORMAT ( ' 1  CRASH  VICTIM’ ,5X,5A4 , 15 , ’  SEGMENTS’ , 15 , ’  JOINTS’, 58X, 
»  'PAGE' .I5/120X, ’CARD  B. 1 ’ /25X, ’PRINCIPAL  MOMENTS  OF  INERTIA 

*  14X, ’SEGMENT  CONTACT  ELLIPSOID’ ,28X, ’CARDS  B.2’/ 

»  3X,  ’SEGMENT’  ,6X,  ’WIGHT’  ,7X,  ’  ( ’  ,  A4 ,  ’  -  ’  ,  A4 ,  ’  «#2- '  ,A4 ,  * )  ’  . 

»  1 IX, ’SEMIAXES  (’ ,A4,’) ’ ,12X, 'CENTER  (’,A4,’)’f 

*  1 IX . 'PRINCIPAL  AXES  (DEG)’/ 
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*  '  I  SYM  PLOT  ( ’ , A4 , ’ ) ’ ,7X, ’ X’ , 8X, ’ Y’ ,8X, 'Z  BIHPOT 

»  2(9X, ’X’ ,7X, ’Y’ ,7X, ’Z* ) ,8X, ’YAW’ ,5X, ’PITCH’ ,5X, ’ROLL’/)  BIHPOT 

BIHPOT 

PRIHT  CARDS  B.2.I  FOR  EACH  SEGMENT.  BIHPOT 

BIHPOT 

DO  31  I=1,HSEG  BIHPOT 

31  WRITE  (6,32)  I , SEG(I) ,CGS(I) ,W(I) , (PHI (J,I) ,J=1 ,3) ,  BIHPOT 

»  (BD(J,I) ,J=1 ,6) , (YPRPMI (J,I) ,J=1,3)  BIHPOT 

32  FORMAT (13 , IX. A4 ,2X, A1 ,F1 1 . 3 ,2X,3F9. 4 ,2 (2X.3F8 . 3) .1X.3F9.2)  BIHPOT 

IF  (HJHT.EQ.O)  GO  TO  50  B0TLER1 

BIHPOT 

PRIHT  CARDS  B.3.J  FOR  EACH  JOIHT.  BIHPOT 

BIHPOT 

IF (IDYPRT.EQ.O)  WRITE (6 ,33)  OHITL.OHITL  TGII0D5 

IFdDYPRT.EQ.  1)  WRITE(6,733)  OHITL.OHITL  TGM0D5 

33  FORMAT (///120X, 'CARDS  B.3'/  BIHPOT 

*  3X, ' JOIHT’ , 15X, ' LOCATIOH ( ' ,A4 , ' )  -  SEG(JHT) ’ ,  BIHPOT 

»  3X ,  ’  LOCATIOH  ( '  ,  A4 , 1 )  -  SEG(J*1) ’ ,  BIHPOT 

»  2X,  ’PRIH.  AXIS (DEG)  -  SEG(JHT) ’ ,  BIHPOT 

*  2X,  ’PRIN.  AXIS  (DEG)  SEG(J+1)’/  BIHPOT 

»  ’  J  SYM  PLOT  JHT  PIN’ ,  2(6X, ’X’ ,8X, ’Y’ ,8X, ’Z’ ,3X) ,  BIHPOT 

»  2(5X, ’YAW’ ,5X, ’PITCH’ ,5X, ’BOLL’ , IX)  /)  BIHPOT 

733  F0RMAT(///120X, ’CARDS  B.3’/  TGM0D5 

»  3X, ’JOINT' , 15X, ’ LOCATIOH ( ’ ,A4, ’ )  -  SEG(JHT) ’ ,  TGM0D5 

*  3X , ’ LOCATIOH ( ’ , A4 , ’ )  -  SEG(J+1) ’ ,  TGM0D5 

*  2X.  'PRIH.  AXIS (DEG)  -  SEG(JHT)’,  TGM0D5 

*  2X ,  ’PRIH.  AXIS (DEG)  -  SEG(J+1)’/  TGM0D5 

*  ’  J  SYM  PLOT  JHT  PIH’ ,  2 (6X, ’X’ ,8X, ’ Y’ ,8X, ’Z’ ,3X) ,  TGM0D5 

*  ’ ID1  YAW  ID2  PITCH  ID3  ROLL  ’,  TGM0D5 

*  ’ ID4  YAW  ID5  PITCH  ID6  ROLL  ’,/)  TGM0D5 

DO  34  J  = 1 , HJHT  BIHPOT 

IF (IDYPRT.EQ.O)  TGM0D5 

•WRITE  (6,35)  J .JOINT ( J) , JS (J) , JHT (J) , IPIH(J) , ( SR ( I , 2»J-1 ) ,1=1,3) ,  TGM0D5 

*  (SR(I , 2* J ) ,1=1,3) , (YPRl(I.J) ,1=1,3) , (YPR2(I ,J) ,1=1 ,3) BIHPOT 

IFdDYPRT.EQ.  1)  TGM0D5 

•WRITE (6 , 735)  J.JOINT(J) ,JS(J) ,JHT(J) ,IPIH(J) , (SR(I ,2»J-1) , 1=1 ,3) ,  TGM0D5 

*  (SR(I.2«J) ,1=1,3) , (IDYPR(I.J) ,YPB1(I,J) ,1=1,3) ,  TGM0D5 

*  ( IDYPR(I+3 , J) , YPR2 ( I , J) ,1=1,3)  TGM0D5 

IF  (. NOT. EULER (J))  GO  TO  34  SLIP 

IEULER(J)  =  8  BIHPOT 

IF  (IPIN(J) .EQ.4)  GO  TO  34  BINPOT 

IEULER(J)  =  11  +  IPIN(J)  BIHPOT 


IPIN(J)  =  -4  BINPUT 

34  CONTINUE  BIHPUT 

35  FORMAT (I3,1X,A4,2X,A1,2X,2I3,2(1X,3F9.3) ,2 ( IX, 3F9 .2)  )  BINPUT 

735  FORMAT (I3,1X,A4,2X,A1,2X,2I3,2( IX, 3F9 .3) , 2 ( IX, 3 ( IX, 1 1 ,F7 . 2) ) )  TGM0D5 

IF  (.NOT. SLIP)  GO  TO  89  SLIP 

WRITE  (6,83)  UHITM.UHITM  SLIP 

83  FORMAT (//’  UHLOCK  CONDITIONS  FOB  SLIP  JOINTS’/  SLIP 

»  ’  JOIHT  TENSION  COMPRESSION’/  SLIP 


ana  osaaaaa 


*  14X, ' ( * ,A4f’)’ ,7X,’(’ ,A4 ,')'/)  SLIP 

DO  85  J  =  l.NJNT  SLIP 

IF  (EULER(J))  GO  TO  85  SLIP 

IF  (IABS(IPIN(J) ) . LT. 5)  GO  TO  85  SLIP 

WRITE  (6,84)  J,CONST(l,J) ,CONST(2,J)  SLIP 

84  F0RMAT(1X,  I6,4X,F10.3,3X,F10. 3)  SLIP 

85  CONTINUE  SLIP 

B INPUT 

SET  UP  HT  MATRIX  FROM  YPR1  &  YPR2  INPUT.  BINPUT 

HA  IS  3RD  COLUMN  &  HB  IS  2ND  COLUMN  OF  HT.  BINPUT 

FOR  A  SLIP  J0INT(IPIN=7) ,HB  IS  3RD  COLUMN  OF  HT.  SLIP 

BINPUT 

9  IF  (NPRT(23> . NE.O)  WRITE  (6,36)  NPG  SLIP 

IF  (NPRT(23) .NE.O)  NPG=NPG+1  PAGE 

36  FORMAT (’1  HT  ARRAY  AS  COMPUTED  FROM  YPR1  &  YPR2  INPUT. ' ,77X,  PAGE 

*  ’PAGE’ ,15)  PAGE 

DO  38  J  = 1 , NJNT  BINPUT 

SR(4,2*J-1)  =  0.0  SLIP 

SR(4,2»J  )  =  0.0  SLIP 

CALL  DRCYPR  (TMP1 ,  YPR1  ( 1 ,  J)  ,  IDYPRd  .  J) )  BINPUT 

CALL  DRCYPR  (TMP2 , YPR2 (1 , J) , IDYPR(4 , J) )  BINPUT 

DO  37  1=1,3  BINPUT 

ANGD(I.J)  =  0.0  BINPUT 

HAd  ,2*J-1)  =  0.0  BINPUT 

HAd  , 2*J  )  =  0.0  BINPUT 

X  «  2  SLIP 

IF  (IABS(IPIN(J) ) . EQ.7)  K  =  3  SLIP 

HBd  ,2*J-1)  =  TMPl(K.I)  SLIP 

HBd  ,  2*J  )  =  TMP2  (K ,  I )  SLIP 

DO  77  K=1 ,3  SLIP 

HT(I ,K,2*J-1)  =  TMPl(K.I)  SLIP 

77  HT(I , K,2*J  )  =  TMP2 (K, I)  SLIP 

IF  (.NOT. EULER (J))  GO  TO  37  SLIP 

CONST (I , J)  =  YPR3(I , J) * RADIAN  SLIP 

ANG(I.J)  =  ANG(I , J) * RADIAN  -  CONST(I.J)  SLIP 

37  CONTINUE  SLIP 

38  IF  (NPRT(23) .NE.O)  WRITE  (6,39)  J.JOINT(J) ,  BINPUT 

»  ( (HT(I ,K,2*J-1) ,K=1 ,3) , (HT(I ,K,2*J) ,K=1 ,3) ,1=1,3)  BINPUT 

39  FORMAT  CO’ , 14 ,2X , A4 , 3X.3FI2 . 6 .3X.3F12 . 6/ ( 14X,3F12 . 6 .3X.3F12.6) )  BINPUT 

BINPUT 

PRINT  CARDS  B.4.J  FOR  EACH  JOINT.  BINPUT 

BINPUT 

WRITE  (6,41)  NPG , UN I TL , UNI TM , UN I TL , UN I TM  PAGE 

NPG=NPG+ 1  PAGE 

41  FORMAT ( ’ 1  JOINT  TORQUE  CHARACTERISTICS’ ,93X,  PAGE 

*  ’PAGE’ ,15/1 20X, 'CARDS  B.4’/  PAGE 

*23X, ’FLEXURAL  SPRING  CHARACTERISTICS ’, 28X, ’TORSIONAL  SPRING'  ,  BINPUT 
*'  CHARACTERISTICS’//  BINPUT 

*15X, ’SPRING  COEF.  (’ ,2A4, ’/DEG**J) ’ ,6X, 'ENERGY  JOINT’,  BINPUT 

*  7X, ’SPRING  COEF.  (’, 2A4 .’ /DEG** J) ’ ,6X, ’ ENERGY  JOINT’/  ’  JBINPUT 


It'S 

I  vt 


:S 

f 

3 


Si 

m 


a 

S 


»OINT  ’ , 2(8X, 'LINEAR  QUADRATIC  CUBIC  DISSIPATION  STOP  dBINPUT 
*/8X,2(8X, ’ (J=l) ’ ,7X, ’ (J=2) ’ ,7X,  ’ ( J=3) ’ ,7X,’C0EF.  (DEG) ’)/)  BIHPUT 

DO  42  J= 1 ,NJNT  BIMPUT 

J1  =  3*J-2  BINPUT 

J2  =  3»J- 1  BINPUT 

J3  =  3*J  BINPUT 

WRITE  (6,43)  J, JOINT (J) , ( (SPRING (I ,JJ) ,1=1,5) ,JJ=J1 ,J2)  BINPUT 

42  IF  (EULER(J) )  WRITE  (6,44)  (SPRING(I , J3) ,1=1 ,5)  SLIP 

43  FORMAT (13 , IX , A4 ,2 (3X,3F12 . 3 , 2F10 . 3) )  BINPUT 

44  F0RMAT(11X,3F12.3,2F10.3)  BINPUT 

BINPUT 
BINPUT 


PRINT  CARDS  B.5.J  FOR  EACH  JOINT. 


BINPUT 

WRITE  (6,46)  (UNITL,UNITM,UNITT,I=1 ,2) , (UNITL .UNITM, 1= 1 ,2) ,UNITT  BINPUT 

46  FORMAT (///120X, ’CARDS  B.5’/  BINPUT 

*38X, 'JOINT  VISCOUS  CHARACTERISTICS  AND  LOCK-UNLOCK  CONDITIONS’//  BINPUT 
*14X, ’VISCOUS’ ,9X, ’COULOMB’ ,7X, ’FULL  FRICTION’ ,5X, ’MAX  TORQUE  FOR’ .BINPUT 
»4X, 'MIN  TORQUE  FOR’ ,4X, ’MIN.  ANG.  VELOCITY’ ,6X, ’ IMPULSE’ /  BINPUT 

»2X, ’JOINT’ ,5X, ’COEFFICIENT’ ,4X, 'FRICTION  COEF.  ANGULAR  VELOCITY',  BINPUT 
»4X,’A  LOCKED  JOINT’ ,4X, ’UNLOCKED  JOINT’ ,4X, ’FOR  UNLOCKED  JOINT’,  BINPUT 

*4X, ’RESTITUTION’/  BINPUT 

»8X , ’ ( ’ , 3A4 , ’ /DEG)  ( ’ ,2A4 , ’ ) ’ ,6X, ’ (DEG/ ’ , A4 , ’ ) ’ , 10X, ’ ( ’ , 2A4 , ’ ) ’ ,  BINPUT 
*8X,’(’,2A4,’)’,10X, ’(RAD/’, A4,’)’,8X, ’COEFFICIENT’/  )  BINPUT 

DO  47  J= 1 , NJNT  BINPUT 

J1  =  3*J-2  BINPUT 

J2  =  3#J-1  BINPUT 

J3  =  3*  J  BINPUT 

WRITE  (6,48)  J,JOINT(J) , (VISC(I, Jl) ,1=1,7)  BINPUT 

47  IF  (EULER(J))  WRITE  (6,49)  { (VISC(I ,JJ) ,1=1 ,7) ,JJ=J2,J3)  SLIP 

48  FORMAT (13 ,1X,A4,F13.3,2F15.2 ,F22 . 2 ,F18 . 2 ,F20 . 2 ,F17 . 3)  BINPUT 

49  FORMAT (  8X.F13 . 3 , 2F15 . 2 ,F22 . 2 ,F18. 2 ,F20. 2 ,F17. 3)  BINPUT 

BINPUT 
BINPUT 
BINPUT 
PAGE 
PAGE 
PAGE 


PRINT  CARDS  B.6.I  FOR  EACH  SEGMENT. 

50  WRITE  (6,51)  NPG, (UNITT, UNITL, UNITT, 1=1,2) 
NPG=NPG+ 1 

51  FORMAT( ’ 1 ’ , 122X, ’PAGE’ , I5/20X, 


*  ’SEGMENT  INTEGRATION  CONVERGENCE  TEST  INPUT’ ,58X, ’CARDS  B.6’//PAGE 

*  17X, ’ANGULAR  VELOCITIES’ ,  1 IX, ’LINEAR  VELOCITIES' .  BINPUT 

*  10X, ’ANGULAR  ACCELERATIONS' ,9X, ’LINEAR  ACCELERATIONS’/  BINPUT 

»  21X, ’ (RAD/’ ,A4, ’) ’ ,  18X, ’ (’ ,A4, ’/’ ,A4, ’) ’ ,  BINPUT 

*  17X, ’ (RAD/’ ,A4, ’**2) ’ .  16X , ’ ( ’ , A4 , ’ / ’ , A4 , ’ *«2) ’ /  BINPUT 

*  ’  SEGMENT’,  4 ( ’  MAG.  ABS.  REL.’)  /  BINPUT 

*  '  NO.  SYM’ ,  4 ( ’  TEST  ERROR  ERROR’)  /)  BINPUT 

DO  52  1=1 ,NSEG  BINPUT 

52  WRITE  (6,53)  I ,SEG(I) , ( (SGTEST(J,K,I) ,J=1 ,3) ,K=1 ,4)  BINPUT 

53  FORMAT (13 , 1X,A4,4(F11.3,F9.3,F9.4)  )  BINPUT 

IF  (NFLX.EQ.O)  GO  TO  62  BINPUT 

BINPUT 

INPUT  AND  PRINT  CARDS  B.7  BINPUT 


?m 


CARD  B.7.A  NFX:  HO.  OF  INTERIOR  SEGMENTS  OF  FLEXIBLE  ELEMENTS.  BINPUT 


KNT(J) , J=1 ,NFX:  THE  SEGMENT  NUMBERS.  BINPUT 

BINPUT 

READ  (5,54)  NFX, (KNT(J) ,J=1 , NFX)  BINPUT 

54  FORMAT (1814)  BINPUT 

IF  (NFX.NE.NFLX)  WRITE  (6,55)  NFX.NFLX  BINPUT 

55  FORMAT (’0 INPUT  ERROR  ON  CARD  B.7.A,  NFX  =’,I4,  *  BUT  NFLX  =’,14/  BINPUT 

«  *  AS  COMPUTED  FROM  CARDS  B.3.  PROGRAM  TERMINATED.’)  BINPUT 

IF  (NFX.NE.NFLX)  STOP  4  BINPUT 

WRITE  (6,56)  NPG  PAGE 

NPG=NPG+ 1  PAGE 

56  FORMAT ( *  1 ' , 122X, ’PAGE’ , 1 5/ 12 IX, ’CARDS  B.7’)  PAGE 

DO  60  JJ=1,NFX  BINPUT 

DO  57  K= 1 , NFLX  BINPUT 

IF  (KNT(JJ) .EQ.NFLEX(2,K) )  GO  TO  59  BINPUT 

57  CONTINUE  BINPUT 

WRITE  (6,58)  KNT(JJ)  BINPUT 

58  FORMAT COINPUT  ERROR  ON  CARD  B.7.J.  SEGMENT  NO. ’,14,’  IS  NOT  AN  I NB INPUT 
•TERIOR  SEGMENT  OF  A  FLEXIBLE  ELEMENT  FROM  DATA  ON  CARDS  B.3.'/  BINPUT 

*  ’  PROGRAM  TERMINATED. ’)  BINPUT 

STOP  5  BINPUT 

59  IF (NFLX.GT.MNFLX)  STOP  99  TGM0D5 

BINPUT 

CARDS  B.7.J  HF  ARRAY  FOR  SEGMENT  KNT(JJ)  BINPUT 

BINPUT 

READ  (5,29)  ( (HF(I , J ,K) . J=1 , 12) ,1=1 ,4)  TGM0D5 

DO  737  LL= 1 ,3  TGM0D5 

L  =  (LL-1) *4  TGM0D5 

DO  737  1=1,4  TGM0D5 

DO  737  J= 1 ,4  TGM0D5 

737  IF (HF( I , J+L.K) . NE . HF ( J , I+L ,K) )  STOP  100  TGM0D5 

60  WRITE  (6,61)  KNT(JJ) ,K, (NFLEX(I ,K) ,1=1,3) ,  BINPUT 

*  ((HF(I.J,K) ,J=1,12) ,1=1,4)  BINPUT 

61  FORMAT ( ’ 0  HF  ARRAY  FOR  INTERIOR  SEGMENT  N0.’,I4,20X,  BINPUT 

*  ’ (NFLEX(I, ’ ,11, ’) ,1=1,3)  =’,316//  BINPUT 

*  (3X.4F10 . 4 ,3X, 4F10 . 4 ,3X, 4F10 . 4)  )  BINPUT 

62  IF  (NJNT.EQ.O)  GO  TO  65  BINPUT 

BINPUT 

CHANGE  SPRING  AND  VISC  FROM  DEG  TO  RAD  BINPUT 

BINPUT 

DO  64  1=1, NJNT  BINPUT 

J1  =  3*1-2  BINPUT 

J2  =  3*1-1  BINPUT 

IF  (EULER(I) )  J2=  3*1  SLIP 

DO  63  J=J1,J2  BINPUT 

SPRING! 1 , J)  =  SPRING(l.J) /RADIAN  BINPUT 

SPRING(2,J)  =  SPRING (2 , J) /RADI AN* *2  BINPUT 

SPRING(3,J)  =  SPRING (3 ,J) /RADI AN* *3  BINPUT 

SPRING(5,J)  =  SPRING(5 , J) * RADI AN  BINPUT 

63  CONTINUE  BINPUT 


bvZ 


64 


IF  ( . NOT . EULER ( I ) ) 
DO  64  J=J1 ,  J2 
VISC  (l.J)  =  vise 
VISC  (3  ,  J)  =  VISC 


J2  =  J1 

(l.J) /RADIAN 
(3  ,  J)  *  HAD  I  AN 


C 

C 

C 

C 

C 

C 

C 


V  ARRAY  HAS  BEEN  SUPPLIED  IN  LBS.  SET  UP  RECIPROCAL  MASS  (RW) 

AND  MOMENT  OF  INERTIA  (RPHI)  ARRAYS.  HOWEVER,  IF  W  OR  ANY  ELEMENT 
OF  PHI  IS  ZERO,  SEGMENT  WILL  BE  CONSIDERED  SINGULAR  (ISING=1)  AND 
ALL  RECIPROCALS  WILL  BE  ZERO  SO  AS  TO  NULLIFY  COMPUTATIONS  IN  THE 
DAUX  ROUTINES.  NS  IS  THE  NUMBER  OF  SINGULAR  SEGMENTS. 


SLIP 

BINPUT 

B INPUT 

BINPUT 

BINPUT 

BINPUT 

BINPUT 

BINPUT 

BINPUT 

BINPUT 

BINPUT 


*  ♦  ■  i. 

65  NS  =  0 

BINPUT 

DO  68  1=1, NSEG 

BINPUT 

l  ■ 

ISING(I)  =  0 

BINPUT 

RW(I)  =  0.0 

BINPUT 

& 

IF  (W(I) .EQ.0.0)  ISING(I)  =  1 

BINPUT 

v.y; 

DO  66  K=1 ,3 

BINPUT 

>«y 

v-y 

V.V 

IF  (PHI (K, I) .EQ.0.0)  ISING(I)  =  1 

BINPUT 

66  RPHI (K , I )  =0.0 

BINPUT 

• 

IF  (ISING(I) .EQ. 1)  NS  =  NS+1 

BINPUT 

IF  (ISING(I) .EQ. 1)  GO  TO  68  BINPUT 

RW(I)  =  G/W(I)  BINPUT 

DO  67  K=1 ,3  BINPUT 

67  RPHI(K.I)  =  1 .O/PHI (K, I)  BINPUT 

68  CONTINUE  BINPUT 

C  BINPUT 

C  SET  UP  ELLIPSOID  MATRIX  AND  INVERSE  (ASSUME  YAW, PITCH. ROLL  =  0)  BINPUT 
C  FOR  1ST  NSEG  ELLIPSOIDS  IN  BD{7-15)  AND  BD(16-24).  BINPUT 

C  BINPUT 

DO  71  J  =  1 , NSEG  BINPUT 

DO  70  1=7,24  BINPUT 

70  BD ( I , J)  =  0.0  BINPUT 

DO  71  1=1,3  BINPUT 

BD(4*I+3,J)  =  1.0/BD(I,J)**2  BINPUT 

71  BD (4*1+12, J)  =  BD ( I , J) **2  BINPUT 

RETURN  BINPUT 

END  BINPUT 


SUBROUTINE  BLKDTA  BLKDTA 

C  REV  IV  07/23/86TW0PI 

C  THIS  SUBROUTINE  REPLACES  THE  BLOCK  DATA  SUBPROGRAM  OF  PREVIOUS  BLKDTA 

C  VERSIONS  OF  CVS-III  TO  INITIALIZE  COMMON/CHSNTS/  IN  A  MANNER  BLKDTA 

C  THAT  IS  INDEPENDENT  OF  THE  COMPUTER  SYSTEM  BEING  UTILIZED.  BLKDTA 

C  BLKDTA 

IMPLICIT  REAL«8  (A-H.O-Z)  BLKDTA 

COMMON/ CNSNTS/  PI .RADIAN, G, THIRD, EPS(24) ,  BLKDTA 

*  UNITL,UNITM,UNITT,GRAVTY(3) .TWOPI  TWOPI 

COMMON/TEMP VS/  ZERO , ONE , THREE , TEN , 0NE80  BLKDTA 

DATA  UM/8H  LBS  /  ,  UT/8H  SEC  /  ,  UL/8H  IN  /  BLKDTA 

ZERO  =0.0  BLKDTA 

ONE  =1.0  BLKDTA 

UNITM  =  UM  BLKDTA 

UNITT  =  UT  BLKDTA 

UNITL  =  UL  BLKDTA 

G  =  386.088D0  BLKDTA 

GRAVTY ( 1 )  =  ZERO  BLKDTA 

GRAVTY ( 2 )  =  ZERO  BLKDTA 

GRAVTY (3)  =  G  BLKDTA 

THREE  =3.0  BLKDTA 

TEN  =10.0  BLKDTA 

0NE80  =  180.0  BLKDTA 

PI  =  DATAN2 (ZERO .-ONE)  BLKDTA 

TWOPI  =  2.0»PI  TWOPI 

RADIAN  =  PI/0NE80  BLKDTA 

THIRD  =  ONE/THREE  BLKDTA 

EPS ( 1)  =  ONE/TEN  BLKDTA 

DO  10  1=2.24  BLKDTA 

10  EPS (I)  =  EPS ( I- 1) /TEN  BLKDTA 

RETURN  BLKDTA 

END  BLKDTA 


SUBBOOT IKE  CFACTT (A,B ,D) 

BEV  03 

GIVEK  3X3  MATRIX  A 

COMPUTE  B  TRANSPOSE  OF  COFACTOBS  (SIGNED  MINOBS) 

AND  D  THE  VALUE  OF  THE  DETEBMINANT  OF  A. 

INVERSE  OF  A  IS  B(J,X)/D 

IMPLICIT  REAL«8  (A-H.O-Z) 

DIMENSION  A(3,3) ,B(3,3) 

M  -  4 
L  =  2 
N  =  3 
D  =  0.0 
DO  20  J=1 ,3 

B(J  ,  J)  =  A(L.L)«A(N,N)-A(L,N)«A(N,L) 

IF  (J.EQ.3)  GO  TO  20 
L  =  N 
N  =  J 
KK  =  J+l 
DO  15  K=KK,3 
M  =  M-l 

B(K, J)  =  A(K,M)*A(M,J)-A(K,J)*A(M,M) 

15  B (J ,K)  =  A(J ,M) *A(M,K)  -  A(J ,K) »A(M,M) 

20  D  =  D+A( 1 , J) »B(J , 1) 

RETURN 

END 


CFACTT 

05/31/73CFACTT 

CFACTT 

CFACTT 

CFACTT 

CFACTT 

CFACTT 

CFACTT 

CFACTT 

CFACTT 

CFACTT 

CFACTT 

CFACTT 

CFACTT 

CFACTT 

CFACTT 

CFACTT 

CFACTT 

CFACTT 

CFACTT 

CFACTT 

CFACTT 

CFACTT 

CFACTT 

CFACTT 

CFACTT 
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SUBROUTINE  CHAINdSKIP)  JDRIFT 

C  REV  IV  07/24/86SLIP 

C  COMPUTES  THE  LINEAR  POSITION  AND  VELOCITY  IN  INERTIAL  REFERENCE  CHAIN 

C  OF  BODY  SEGMENTS  FROM  THOSE  OF  THE  REFERENCE  SEGMENTS  CHAIN 

C  (I.E.,  SEGMENT  NO.  1  AND  EACH  SEGMENT  J  FOB  WHICH  JNT(J)=0).  CHAIN 

C  CHAIN 

IMPLICIT  REAL*8 (A-H.O-Z)  CHAIN 

COMMON/CONTRL/  TIME , NSEG , NJNT , NPL , NBLT , NBAG , NVEH , NGRND ,  CHAIN 

*  NS , NQ , NSD , NFLX , NHRNSS , NWINDF , NJNTF ,NPRT (36) , NPG  PAGE 

COMMON/ SGMNTS/  D(3,3,30) ,WMEG(3,30) ,WMEGD(3,30) ,U1(3,30) ,U2(3,30) .CHAIN 

*  SEGLP(3,30) ,SEGLV(3,30) ,SEGLA(3,30) ,NSYM(30)  CHAIN 

COMMON/DESCRP/  PHI (3,30) ,W(30) ,RW(30) ,SR(4,60) ,HA(3,60) ,HB(3,60) .  SLIP 

*  RPHI (3,30) ,HT(3,3,60) .SPRING (5, 90) ,VISC(7,90) ,  CHAIN 

*  JNT(30) ,IPIN(30) ,ISING(30) ,IGL0B(30) ,J0INTF(30)  CHAIN 

COMMON/ CEULER/  IEULER(30) ,HIR(3,3,90) ,ANG(3,30) ,ANGD(3,30) ,  SLIP 

*  FE(3,30) ,TQE(3,30) ,CONST(5,30)  SLIP 

COMMON/TEMPVS/  T1 (3) . T2 (3) ,T3(3) ,T4(3) ,T5(3) ,T6(3) ,T7(3)  SLIP 

DATA  IFIRST/1/  SLIP 

CALL  ELTIME  (1,11)  ATBIII 

IF  (NJNT.EQ.O)  GO  TO  71  ATBIII 

IF (ISKIP . NE. 0)  CALL  DRIFT  JDRIFT 

DO  70  J  = 1 , NJNT  ATBIII 

K  =  IABS (JNT ( J) )  ATBIII 

IF  (K.EQ.O)  GO  TO  70  ATBIII 

IF  (ISING(J+1) .LT.O)  GO  TO  70  ATBIII 

C  ATBIII 

C  COMPUTE  SEGMENT  POSITIONS  BY  ATBIII 

C  P(J+1)  =  P (K)  +  D(K)’*R(K,J)  -  D(J+1) ’ »R(J+1 , J)  ATBIII 

C  ATBIII 

COMPUTE  SEGMENT  VELOCITIES  BY  ATBIII 

V(J+1)  =  V(K)  +  D(K)’»W(K)  X  ROC, J)  -  D(J+1) ’ *W(J+1)  X  R(J+1,J)  ATBIII 
C  ATBIII 

CALL  CROSS  (WMEG(l.K) ,SR(1,2*J-1) ,T1)  JDRIFT 

CALL  DOT31  (D ( 1 , 1 ,K) ,T1 ,T3)  ATBIII 

CALL  CROSS  (WMEG(1,J+1) ,SR(1,2*J) ,T2)  ATBIII 

CALL  DOT31  (D( 1 , 1 , J+ 1) ,T2 ,T4)  ATBIII 

CALL  DOT31  (D ( 1 , 1 ,K) , SR< 1 , 2»J- 1) ,T1 )  ATBIII 

CALL  DOT31  (D( 1 , 1 , J+l) ,SR( 1 , 2«J) ,T2)  ATBIII 

IF  (IABS(IPIN(J) ) .LT.5)  GO  TO  50  SLIP 

IF  (IEULER(J)  .EQ.-DGO  TO  50  SLIP 

IF  (IFIRST.EQ. 1)  GO  TO  50  SLIP 

DO  40  I  =  1,3  SLIP 

T5 ( I )  =  SEGLP(I , J+l)  +  T2 (I)  -  SEGLP(I.K)  -  T 1 ( I )  SLIP 

40  T6(I)  =  SEGLV(I ,J+1)  +  T4(I)  -  SEGLV(I.K)  -  T3(I)  SLIP 

CALL  DOT31  (D(l , 1 ,X) ,HT(1 ,3,2»J-1) ,T7)  SLIP 

SR(4 ,2»J- 1 )  =  T5(l) *T7 ( 1)  +  T5(2)«T7(2)  +  T5 (3) *T7 (3)  SLIP 

SR(4,2*J  )  =  T6(1)*T7(1)  ♦  T6(2)»T7(2)  +  T6(3)»T7(3)  SLIP 

CALL  CROSS  (WMEG(l.K) ,HT(1 ,3,2*J-1) ,T5)  SLIP 

CALL  DOT31  (Dd  ,  1  ,K)  ,T5,T6)  SLIP 

DO  45  I  =1  ,3  SLIP 


89 


c 

c 

c 


T1(I)  =  Tl(I)  ♦  SR(4,2»J-1)«T7(I) 

SLIP 

45  T3 ( I)  =  T3(I)  +  SR(4 , 2*J  )*T7(I) 

♦  SR(4,2»J-1)*T6(I) 

SLIP 

50  DO  60  1=1,3 

SLIP 

SEGLP ( I , J  + 1 )  =  SEGLP(I.K)  ♦  T1(I) 

-  T2 (I) 

ATBIII 

60  SEGLVU.J+l)  =  SEGLV(I.K)  +  T3(I) 

-  T4 (I) 

ATBIII 

70  CONTINUE 

CHAIN 

IFIRST  =  0 

SLIP 

CHAIN 

OPTIONAL  OUTPUT 

CHAIN 

CHAIN 

71  IF  (NPRT(20) .NE.O) 

WRITE (6 , 90) 

TIME 

CHAIN 

, ((SEGLP (I 

,  J) ,1*1,3) , J= 1 , NSEG) 

CHAIN 

« 

, ( (SEGLV(I 

,J) ,1=1,3) , J=1 , NSEG) 

CHAIM 

90  FORMAT (’0  LINEAR  POSITIONS  AND  VELOCITIES  OF  BODY  SEGMENTS 

FROM  CHCHAIN 

•AIN  FOR  TIME  =’ ,F12, 

.6/ (0F13.5) > 

CHAIN 

CALL  ELTIME(2, 11) 

CHAIN 

RETURN 

CHAIM 

END 

CHAIN 

SUBBOUT I NE  CINPUT  C INPUT 

REV  I H.  2  08/08/84REVIII 

INPUT  CARDS  E.l  -  E.4  FOR  THE  FORCE-DEFLECTION,  INERTIAL  SPIKE,  CINPUT 
R  FACTOR,  G  FACTOR  AND  FRICTION  COEFFICIENT  FUNCTION  DEFINITIONS  CINPUT 


CINPUT 

IMPLICIT  REAL*8 (A-H.O-Z)  CINPUT 

COMMON/CONTRL/  T I ME , NSEG , N JNT , NPL , NBLT , NBAG , NVEH , NGRND ,  PAGE 

*  NS , NQ , NSD , NFLX , NHRNSS , NWI NDF , NJNTF , NPRT ( 36 ) , NPG  PAGE 

COMMON/TABLES / MXNTI , MXNTB , MXTB 1 , MXTB2 ,NTI (50) , NTAB ( 1 2  50) , TAB ( 4500 ) DIMENB 
COMMON/TEMPVS/ JTITLE (5 , 51) ,NF(5) ,NT(3) ,KTITLE(31)  CINPUT 

REAL  JTITLE, KTITLE  CINPUT 

CINPUT 

IS  =  0  CINPUT 

DO  10  I  =  1,50  CINPUT 

10  NTI (I)  =  0  CINPUT 

J1  =  l  CINPUT 

CINPUT 

INPUT  CARD  E.l  -  FUNCTION  NO.  AND  TITLE,  IF  NO.  >  50  SKIP  OUT.  CINPUT 

CINPUT 

11  READ (5,12)  I , (KTITLE ( J  ) ,J  =  1.5)  CINPUT 

12  FORMAT  (I4.4X.5A4)  CINPUT 

IF  (I.GT.50)  GO  TO  30  CINPUT 

DO  13  J  =  1.5  CINPUT 

13  JTITLE(J.I)  =  KTITLE (J)  CINPUT 

CINPUT 

HAS  FUNCTION  NO.  BEEN  ALREADY  USED?  CINPUT 

CINPUT 

IF  (NTI (I) .NE.O)  WRITE (6 , 14)  I  CINPUT 

14  FORMAT ( ’ 0  FUNCTION  NO.’, 14,’  HAS  ALREADY  BEEN  INPUTTED  AND  WILL  BECINPUT 

* REPLACED  BY  NEXT  FUNCTION’)  CINPUT 

NTI (I)  =  J1  CINPUT 

J2  =  Jl+4  CINPUT 

CINPUT 

INPUT  CARD  E.2  CINPUT 

CINPUT 

READ (5 , 15)  (TAB(J) ,J  =  J1.J2)  CINPUT 

15  FORMAT  (6F12.0)  CINPUT 

IS  =  1 - IS  CINPUT 

IF  (IS.EQ.O)  WRITE (6 , 16)  CINPUT 

IF  (IS.EQ.O)  GOTO  40  PAGE 

WRITE (6, 41)  NPG  PAGE 

41  FORMAT( ’ 1’ , 122X, ’PAGE’ ,15)  PAGE 

NPG=NPG+ 1  PAGE 

16  FORMAT (/////)  CINPUT 

40  WRITE(6,17)  I , (JTITLE (J , I ) , J=1 ,5) , I ,NTI (I ) , (TAB(J) , J=J1 , J2)  PAGE 

17  FORMAT (’  FUNCTION  NO. ' ,14, 4X.5A4.20X, ’NTIC ,12, ’)  «' ,15,451,  PAGE 

»  'CARDS  E’/ZIOX,  'DO*  ,  13X,  ’Dl’  ,  13X,  ’D2\13X,  ’D3’  ,  13X,  ’D4’/5F15.4//)CINPUT 
DO  =  TAB(Jl)  CINPUT 

Dl  =  TAB ( J 1 ♦ 1 )  CINPUT 

D2  =  TAB(Jl+2)  CINPUT 


m 

a 

i 

a 

is 
( 


J1  =  J2+1 
IF  (Dl)  22,18,20 

FUNCTION  IS  CONSTANT  D2  FOR  ALL  D. 

18  WRITE(6 , 19)  D2 

19  FORMAT (7X. ’FUNCTION  IS  CONSTANT’ ,F12. 6) 

GO  TO  11 

5TH  ORDER  POLYNOMIAL  ...  1ST  FUNCTION 
INPUT  CARD  E.3 

20  J2  =  Jl+5 

READ (5, 15) (TAB(J) , J  =  J1.J2) 

WRITE (6,21)  (TAB(J) ,J  =  J1.J2) 

21  FORMAT (7X, ’FIRST  PART  OF  FUNCTION  -  5TH  DEGREE  POLYNOMIAL'// 

*  8X, ’AO* ,13X,’A1’ ,13X,'A2’ ,13X,’A3’ ,13X,’A4’ ,13X,’A5’ 

*  8F15.6//) 

J1  =  J2+ 1 

GO  TO  25 

TABLE  LOAD  ...  1ST  FUNCTION 
INPUT  CARDS  E.4.A-E.4.N 

22  READ (5, 23)  NPI 

23  FORMAT  (1216) 

TAB(Jl)  =  NPI 
J1  =  Jl  +  1 

J2  =  J1+2»NPI- 1 

READ(5, 15) (TAB(J) , J  =  J1,J2) 

WRITE (6 , 24)  NPI,  (TAB ( J)  ,J  =  Jl,  J2) 

24  FORMAT (7X, 'FIRST  FART  OF  FUNCTION  -  ’,14,’  TABULAR  POINTS’// 

«  8X, ’D‘ ,16X, ’F(D) ’  /(F15.6.F15.4)) 

Jl  =  J2+1 

CHECK  FOR  SECOND  FUNCTION 

25  IF (D2)  28,11,26 

SECOND  FUNCTION  ...  5TH  ORDER  POLYNOMIAL 
INPUT  CARD  E.3 

26  J2  =  Jl+5 

READ (5 ,15) (TAB(J) , J  =  J1.J2) 

WRITE (6 , 27)  (TAB(J) ,J  =  J1.J2) 

27  FORMAT ( 7 X, 'SECOND  PART  OF  FUNCTION  -  5TH  DEGREE  POLYNOMIAL’// 

»  8X, ’BO’ ,13X, 'Bl ’ , 13X, ’B2’ ,13X, ’B3’ ,13X, ’B4’ ,13X, ’B5’ 

»  6F15.8//) 

Jl  =  J2+ 1 
GO  TO  11 


C INPUT 
C  INPUT 
CINPUT 
C INPUT 
CINPUT 
CINPUT 
CINPUT 
CINPUT 
CINPUT 
CINPUT 
CINPUT 
CINPUT 
CINPUT 
CINPUT 
CINPUT 
CINPUT 
,  13X/CINPUT 
CINPUT 
CINPUT 
CINPUT 
CINPUT 
CINPUT 
CINPUT 
CINPUT 
CINPUT 
CINPUT 
CINPUT 
CINPUT 
CINPUT 
CINPUT 
CINPUT 
CINPUT 
CINPUT 
CINPUT 
CINPUT 
CINPUT 
CINPUT 
CINPUT 
CINPUT 
CINPUT 
CINPUT 
CINPUT 
CINPUT 
CINPUT 
CINPUT 
CINPUT 
,13X/ CINPUT 
CINPUT 
CINPUT 
CINPUT 


VT 

f 

& 


SECOND  FUNCTION  . . .  TABLE  LOAD 
INPUT  CARDS  E.4.A-E.4.N 

26  RE AD (5, 23)  NPI 
TAB(Jl)  =  NPI 
J1  =  Jl  +  1 
J2  =  J1+2«NPI-1 
READ (5, 15) (TABIJ) ,J  =  J1.J2) 

WRITE (6 , 29)  NPI.  (TAB(J) .  J  =  J1.J2) 

29  FORMAT (7X. ’SECOND  PART  OF  FUNCTION  -  ’,14,’  TABULAR  POINTS’// 

«  8X,’D’,16X,'F<D)’  / (F15 . 6 , F 1 5 . 4 ) ) 

J1  =  J2+ 1 
GO  TO  11 

30  MXTB1  =  Jl-1 
CALL  K INPUT 
CALL  FINPUT 
CALL  HINPUT 
RETURN 

END 


C INPUT 
C INPUT 
C INPUT 
C INPUT 
C INPUT 
C INPUT 
C INPUT 
C INPUT 
C INPUT 
C INPUT 
C INPUT 
C INPUT 
C INPUT 
C INPUT 
C INPUT 
C INPUT 
C INPUT 
C INPUT 
C INPUT 
C INPUT 


SUBROUTINE  CMPUTE  (K.M.FT)  CMPUTE 

BEV  I I I. 2  08/08/84BEVIII 

IMPLICIT  REAL *8  (A-H.O-Z)  CMPUTE 

COMMON/CONTRL/  TIME, NSEG , NJNT , NPL , NBLT , NBAS , NVEH , NGRNO ,  CMPUTE 

NS , NQ , NSD , NFLX , NHRNSS , NWI NDF , NJNTF , NPRT ( 36 ) , NPQ  PAGE 

COMMON/CDINT/  UU(4) ,GH(3,4) ,  CMPUTE 

E(3 , 240) ,  F(5,240) ,GG(5,240) ,Y(5,240) ,U(5,240) ,  CMPUTE 

H , HPRI NT , HS . TPRI NT , TSTART . ICNT , IDBL , I FLAG  CMPUTE 

COMMON/COMAIN/  VAR ( 240 ) , DER ( 240) , DT , HO , HMAX , HMIN , RSTIME ,  CMPUTE 

ISTEP .NSTEPS , NDINT , NEQ . IRSIN , IRSOUT  CMPUTE 

TIME  =  TSTART  ♦  FT  CMPUTE 

CALL  DZP  ( NEQ , VAR , GG , E , FT , M)  CMPUTE 

IF  (NPRT (26) .EQ. 2)  CALL  OUTPUT (0)  CMPUTE 

CALL  PDAUX  (VAR, DER, NEQ ,K)  CMPUTE 

IF  (NPRT (26) .EQ. 2)  CALL  OUTPUT (1)  CMPUTE 

RETURN  CMPUTE 

END  CMPUTE 


CMPUTE 

PAGE 

CMPUTE 

CMPUTE 

CMPUTE 

CMPUTE 

CMPUTE 

CMPUTE 

CMPUTE 

CMPUTE 

CMPUTE 

CMPUTE 

CMPUTE 

CMPUTE 


1 
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SUBROUTINE  CONTCT  CONTCT 

REV  III. 2  08/08/84REVIII 

CONTROLS  THE  CALLING  OF  SUBROUTINES  REQUIRED  TO  COMPUTE  THOSE  CONTCT 
EXTERNAL  FORCES  AND  TORQUES  ACTING  ON  THE  BODY  SEGMENTS.  CONTCT 

CONTCT 

IMPLICIT  REAL *8  (A-H.O-Z)  CONTCT 

COMMON/CONTRL/  T I ME , NSEG , NJNT , NPL , NBLT , NBAG , NVEH , NGRND ,  CONTCT 

*  NS , NQ , NSD , NFLX , NHRNSS , NWINDF , NJNTF , HPRT ( 30 ) , NPG  PAGE 

COMMON/ JBARTZ/  MNPL(  30) ,MNBLT(  8) ,MNSEG(  30) ,MNBAG(  6) .  CONTCT 

*  MPL (3 ,5,30) ,MBLT (3 ,5,8) ,MSEG(3 ,5 ,30) ,MBAG(3 , 10,6) ,  CONTCT 

»  NTPL(  5,30) .NTBLT (  5,8),NTSEG(  5,30)  CONTCT 

COMMON/FORCES/PSF (7 , 70) ,BSF(4,20) ,SSF(10,40) ,BAGSF(3,20) ,  NCFORC 

»  PRJNT (7,30) , NP ANEL ( 5 ) , NPSF , NBSF , NSSF , NBGSF  CONTCT 

COMMON/TABLES/MXNTI ,MXNTB,MXTBI ,MXTB2,NTI (50) ,NTAB(1250) .TAB (4500) DIMENB 
COMMON/HRNESS/  BAR( 15 . 100) . BB ( 100) , BBDOT ( 100) .PLOSS (2 , 100) ,  CONTCT 

»  XLONG(20) ,HTIME(2) ,IBAR(5,100) ,NL(2,100) ,  CONTCT 

«  NPTSPB(20) ,NPTPLY(20) ,NTHRNS(20) ,NBLTPH(5)  CONTCT 

COMMON/ WINDFR/  WTIME (30) ,QFU(3 , 5) ,QFV(3 , 5) , WF (3 , 30) , IWIND (30) ,  WINDOP 

»  MWSEG(7,30) ,NFVSEG(6) ,NFVNT(5) , M0WSEG(30,30)  WINDOP 

DATA  MAXPSF/70/ .MAXBSF/20/ , MAXSSF/46/  NCFORC 

CHGIII 

MAXSSF  SHOULD  BE  40  BUT  IT  IS  ALLOWED  TO  OVERFLOW  INTO  BAGSF  NCFORC 

CHGIII 

CALL  ELTIME (1,12)  CONTCT 

NPSF  =  0  CONTCT 

NBSF  =  0  CONTCT 

NSSF  =  0  CONTCT 

IF  (NPL.LE.O)  GO  TO  21  CONTCT 

CONTCT 

CALL  PLELP  ROUTINE  FOR  EACH  ALLOWED  PLANE-SEGMENT  CONTACT.  CONTCT 

CONTCT 

DO  20  J  =  1 , NPL  CONTCT 

IF (MNPL(J) .EQ.O)  GO  TO  20  CONTCT 

KPL  =  MNPL(J)  CONTCT 

DO  19  1=1, KPL  CONTCT 

NPSF  =  NPSF+1  CONTCT 

IF (NPSF . GT . MAXPSF)  STOP  57  CHGIII 

Ml  =  MPL ( 1 , I , J)  CONTCT 

M2  =  MPL (2 , I , J)  CONTCT 

M3  =  MPL (3, I, J)  CONTCT 

NT  =  NTPL(I.J)  CONTCT 

JT  =  NTAB(NT)  CONTCT 

TAB ( JT)  =0.0  CONTCT 

19  CALL  PLELP (M2, M3, Ml ,J, NT)  CONTCT 

20  CONTINUE  CONTCT 

21  IF (NBLT . LE . 0)  GO  TO  41  CONTCT 

CONTCT 

CALL  BELTRT  ROUTINE  FOR  EACH  ALLOWED  BELT-SEGMENT  CONTACT.  CONTCT 

CONTCT 

DO  30  J  = 1 , NBLT  CONTCT 


IF (MNBLT(J) .EQ.O)  GO  TO  30 
KBLT  =  MNBLT(J) 

DO  29  1=1, KBLT 
NBSF  =  NBSFd 

IF (NBSF.GT.MAXBSF)  STOP  58 
Ml  =  MBLT(1 , I ,J) 

M2  =  MBLT  (2 , 1 ,  J) 

M3  =  MBLT  (3 , 1 ,  J) 

NT  =  NTBLT(I , J) 

JT  =  NTAB (NT) 

TAB(JT)  =  0.0 
NF  =  HTAB (NT+5) 

IF  (NF.NE.O)  JT  =  NTAB (NT+6) 

IF  (NF.NE.O)  TAB (JT)  =  0.0 

29  CALL  BELTRT(M2,M3,M1,J,NT) 

30  CONTINUE 

CALL  SEGSEG  ROUTINE  FOR  EACH  ALLOWED  SEGMENT-SEGMENT  CONTACT.  CONTCT 

CONTCT 
CONTCT 
CONTCT 
CONTCT 
CONTCT 
CONTCT 
CHGIII 
CONTCT 
CONTCT 
CONTCT 
CONTCT 
CONTCT 
CONTCT 
CONTCT 
CONTCT 
CONTCT 


CALL  AIRBAG  ROUTINE  FOR  ALLOWED  BAG-SEGMENT  CONTACTS,  IF  ANY.  CONTCT 

COHTCT 

IF  (NBAG.NE.O)  CALL  AIRBAG  CONTCT 

CONTCT 

CALL  WINDY  ROUTINE  FOB  WIND  FORCES  ON  EACH  SEGMENT.  CONTCT 

CONTCT 

DO  60  J=1 ,NSEG  CONTCT 

IF  (MWSEG(l.J) .EQ.O)  GO  TO  60  CONTCT 

M=MWSEG(1 , J)  WINDOP 

Ml  =  MWSEG(2 , J)  CONTCT 

M2  =  MWSEG(3,J)  CONTCT 

M3  =  MWSEGU.J)  CONTCT 

NT  =  MWSEG(5 , J)  CONTCT 

CALL  WINDY  (M,M1 , M2, M3, NT)  WINDOP 

60  CONTINUE  CONTCT 


CONTCT 


41  DO  50  J= 1 ,NSEG 

IF(MNSEG(J) .EQ.O)  GO  TO  50 
KSEG  =  MNSEG(J) 

DO  49  1=1, KSEG 
NSSF  =  NSSF+1 

IF (NSSF . GT . MAXSSF)  STOP  59 
Ml  =  MSEG(1,I,J) 

M2  =  MSEG(2 , I , J) 

M3  =  MSEG(3 , I , J) 

NT  =  NTSEG(I.J) 

JT  =  NTAB (NT) 

TAB (JT)  =0.0 

49  CALL  SEGSEG(J,M1,M2,M3,NT) 

50  CONTINUE 


CONTCT 

CONTCT 

CONTCT 

CONTCT 

CHGIII 

CONTCT 

CONTCT 

CONTCT 

CONTCT 

CONTCT 

CONTCT 

CONTCT 

CONTCT 

CONTCT 

CONTCT 

CONTCT 

CONTCT 
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c 
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CALL  WINDY  FOB  FORCE  FUNCE  FUNCTION  CALCULATIONS. 


NFORCE  =  NFVSEQ(6) 

IF  (NFORCE. 6T.O)  CALL  WINDY  (0 .Ml .M2 ,M3 ,NT) 


C 

C 

C 


CALL  HBELT  ROUTINE  FOB  EACH  HARNESS-BELT  SYSTEM. 


IF  (NHRNSS.LE.O)  00  TO  80 
J1  =  1 
KNLO  =  0 

DO  70  Is 1 , MHBNSS 
IF  (NBLTPH(I) .LE.O)  GO  TO  70 
J2  =  J1  ♦  NBLTPH ( I )  -  I 
CALL  HBELT  (J1 , J2 .KNLO ,0) 

J1  =  J2+1 
70  CONTINUE 


C 

C 

C 


CALL  SPDAMP  FOR  SPRING  DAMPER  FORCES,  IF  ANY 


80  IF  (NSD.NE.O)  CALL  SPDAMP 
CALL  ELTIME  (2,12) 

RETURN 

END 
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i  pm  <  m  iAi  i  a«  in  m  m  m  u  m 


CONTCT 

CONTCT 

CONTCT 

WINDOP 

CONTCT 

CONTCT 

CONTCT 

CONTCT 

CONTCT 

CONTCT 

CONTCT 

CONTCT 

CONTCT 

CONTCT 

CONTCT 

CONTCT 

CONTCT 

CONTCT 

CONTCT 

CONTCT 

CONTCT 

CONTCT 

CONTCT 
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SUBROUTINE  CROSS(A,B,C) 

COMPUTES  VECTOR  CROSS  PRODUCT  C  =  A  X  B. 
ARGUMENTS 

A, B ,C:  VECTORS  OF  LENGTH  3  WHERE  C=AXB. 

IMPLICIT  REAL»8  (A-H.O-Z) 

DIMENSION  A(3) ,B(3) , C (3) 

C(l)  =  A(2) *B(3)  -  A(3) *B (2) 

C (2)  =  A(3) »B( 1)  -  A ( 1 ) »B (3) 

C (3)  =  A ( 1) *B (2)  -  A(2) *B( 1) 

RETURN 

END 


REV  03 


CROSS 

05/31/73CR0SS 

CROSS 

CROSS 

CROSS 

CROSS 

CROSS 

CROSS 

CROSS 

CROSS 

CROSS 

CROSS 

CROSS 

CROSS 
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SUBROUTINE  DAUX(Il) 

REV  IV 

COMPUTES  DERIVATIVES  FOR  INTEGRATOR  ROUTINE  BY 

(1)  SET  UP  INITIAL  VALUES  FOB  ARRAY  OF  SYSTEM  EQUATIONS. 

(2)  MODIFY  ARRAYS  BY  CONSTRAINTS. 

(3)  SOLVE  SYSTEM  OF  EQUATION  FOR  F.TQ.QQ  AND  V4. 

(4)  EVALUATE  DERIVATIVES  SEGLA  AND  WMEGD. 


DAUX 

07/24/86SLIP 

DAUX 

DAUX 

DAUX 

DAUX 

DAUX 

DAUX 

DAUX 

DAUX 


IMPLICIT  REAL*8 (A-H.O-Z)  DAUX 
COMMON/CONTRL/  TIME , HSEG , NJNT , NPL , NBLT , NBAG , NVEH , NGRND ,  DAUX 
>  NS , NQ , NSD , NFLX , NHRNSS , NWINDF , NJNTF , NPRT ( 36 ) , NPG  PAGE 
COMMON/ SGMNTS/  D(3,3,30) ,WMEG(3,30) .WMEGD (3 ,30) ,U1(3,30) ,U2(3,30) .DAUX 

*  SEGLP(3,30) ,SEGLV(3,30) .SEGLA (3, 30) ,NSYM(30)  DAUX 
COMMON/DESCRP /  PHI (3,30) ,W(30) ,RW(30) ,SR(4,60) ,HA(3,60) ,HB(3,0O) ,  SLIP 

*  RPHI(3,30) ,HT(3,3,60) , SPRING(5 ,90) ,VISC(7,90) ,  DAUX 
»  JNT(30) ,IPIN(30) ,ISING(30) ,IGL0B(30) ,J0INTF(30)  DAUX 

COMMON/CMATRX/  VI (3,30) ,V2(3,30) ,V3(3,12) ,B12(3,3,60) ,A22(3,3,60) .DAUX 
»  F  (3 ,30)  ,TQ (3 , 30)  , WJ  (30)  , A1 1  (3 ,3 ,30)  SLIP 
COMMON/CSTRNT/  A13(3,3,24) ,A23(3,3,24) ,B31 (3,3,24) ,B32(3,3,24) ,  DAUX 
»  HHT(3,3, 12) , RK1 (3 , 12) ,RK2(3,12) ,QQ(3,I2) ,TQQ(3,12) .DAUX 


*  RQQ (3 , 12) , HQQ(3 , 12) , SQQ (12) ,CFQQ(12) , 

»  KQ1 (12) ,KQ2 ( 12) ,KQTYPE(12) 

COMMON/FLXBLE/  HF ( 4 , 12,8) ,B42(3,3,24) ,V4(3,8) ,NFLEX(3,8) 
COMMON/ CNSNTS/  PI .RADIAN, G.THIRD.EPS (24) , 

»  UNITL,UNITM,UNITT,GRAVTY(3) .TWOPI 

COMMON/RSAVE/  XSG(3,20,3) ,DPMI(3,3,30) ,LPMI (30) , 

»  NSG (9) , MSG (20 ,9) ,MCG,MCGIN(24 ,5) ,KREF(20,9) 

NOTE:  DAUX  SHARES  /TEMPVS/  WITH  DAUX11 , 12,22,31 ,32  &33. 

LOGICAL* 1  FREE 

COMMON/TEMPVS/  C(3,3,600) ,RHS(3,54) ,IJK(54,54) ,IJ,NQ2S, 

*  IDUM(458) .FREE (30) 

DIMENSION  Tl(3) ,T2(3) ,T3(3) 

CALL  ELTIME(1,9) 

IF  IliO,  U1  AND  U2  HAVE  BEEN  SET  UP  BY  CALLING  ROUTINE. 

IF  (Il.NE.O)  GO  TO  8 

SET  UP  INITIAL  VALUES  OF  A  &  B  ARRAYS  AND  U  &  V  VECTORS. 
MODIFY  U1  &  U2  ARRAYS  BY  CONTACT  AND  JOINT  FORCES. 

CALL  CHAIN (NPRT (36) ) 

CALL  SETUP  1 
CALL  VEHPOS 
CALL  CONTCT 
CALL  VISPR (0,0) 

CALL  EJOINT(O.O) 

CALL  SETUP2 


DAUX 

DAUX 

DAUX 

DAUX 

TWOPI 

ATBIII 

TTHKREF 

DAUX 

DAUX 

DAUX 

SLIP 

SLIP 

SLIP 

TGM0D2 

DAUX 

DAUX 

DAUX 

DAUX 

DAUX 

DAUX 

DAUX 

DAUX 

DAUX 

JDRIFT 

DAUX 

DAUX 

DAUX 

DAUX 

DAUX 

DAUX 


O  ft 


IF  (NFLX.GT.O)  CALL  FLXSEG  DAUX 

C  DAUX 

MODIFY  UI.U2  AND  ADD  G  TO  Dl.  DADX 

DAUX 

DO  5  J  = 1 , NGRND  DAUX 

IF  (ISING(J) )  1,3,5  DAUX 

1  DO  2  1=1,3  DAUX 

Ul(I.J)  =  SEGLA(I , J)  DAUX 

2  U2 ( I , J )  =  WMEGD(I.J)  DAUX 

GO  TO  5  DAUX 

3  DO  4  1=1,3  DAUX 

Ul(I.J)  =  U1 (I , J) *RW(J)  +  GBAVTY ( I )  DAUX 

4  U2 (I , J)  =  U2(I , J) *RPHI (I , J)  DAUX 

5  CONTINUE  DAUX 

C  DAUX 

C  SET  UP  BODY  SEGMENT  SYMMETBY  DAUX 

C  NSYM(J)  =0  3D  MOTION  DAUX 

C  NSYM(J)  =  J  CENTBAL  SEGMENT  2D  MOTION,  NO  LATEBAL  MOTION  DAUX 

C  NSYM(J)  =  K  SEGMENT  J  SYMMETRIC  TO  SEGMENT  K,  ALL  MOTION  DAUX 

C  IN  THE  X-Z  PLANE.  NO  LATEBAL  MOTION  DAUX 

C  NSYM(J)  =  -K  SEGMENT  J  MIBBOB  SYMMETBIC  TO  SEGMENT  K.  EQUAL  DAUX 

C  BUT  OPPOSITE  LATEBAL  MOTION  PERMITTED  DAUX 

C  DAUX 

DO  20  J  = 1 , NGRND  DAUX 

IF  (NSYM(J).EQ.O)  GO  TO  20  DAUX 

K  =  IABS (NSYM(J) )  DAUX 

DO  205  L=1 ,3  TGM0D2 

T1(L)  =  U2 (L , J)  TGM0D2 

T2(L)  =  U2(L.K)  TGM0D2 

T3(L)  =  U2(L,J)  TGM0D2 

205  CONTINUE  TGM0D2 

IF(LPMI(J) .EQ.O.AND.LPMI(K) .EQ.O)  GO  TO  201  TGM0D2 

IF (LPMI (J) . NE. 0 . AND. LPMI (X) . EQ. 0)  GO  TO  202  TGM0D2 

IF(LPMI(J) .EQ.O. AND. LPMI(K) .NE.O)  GO  TO  203  TGM0D2 

CALL  D0T31 (DPMI (1,1, J) ,U2(1,J) , Tl)  TGM0D2 

CALL  D0T31 (DPMI ( 1 , 1 ,K) ,U2 ( 1 ,K) ,T2)  TGM0D2 

GO  TO  201  TGM0D2 

202  CALL  D0T31 (DPMI ( 1 , 1 , J) , U2( 1 , J) , T 1 )  TGM0D2 

GO  TO  201  TGM0D2 

203  CALL  D0T31 (DPMI ( 1 , 1 ,K) ,U2 ( 1 ,K) ,T2)  TGM0D2 

201  CONTINUE  TGM0D2 

IF  (NSYM(J) .EQ.J)  GO  TO  19  DAUX 

IF  (K.LT.J)  GO  TO  16  DAUX 

Ul(l.J)  =  0.5* ( U I ( 1 , J)  +  U 1 ( 1 , K) )  DAUX 

U1 (3 , J)  =  0 .5* ( U 1 (3 , J)  +  U1 (3 ,K) )  DAUX 

T3 (2)  =  0.5* (Tl (2)  +  T2 (2) )  TGM0D2 

GO  TO  17  DAUX 

16  Ul(l.J)  =  U1(1,K)  DAUX 

U1(3,J)  =  U1 (3 , K)  DAUX 

T3 (2)  =  T2 (2)  DAUX 


17  IF  (NSYM(J) .GT.O)  GO  TO  19  DAUX 

IF  (K.LT.J)  GO  TO  18  DAUX 

U1(2,J)  =  0.5* ( U 1 (2 , J)  -  U1 (2 ,K) )  DAUX 

T3 ( 1)  =  0.5* (T1 (1 )  -  T2(l) )  TGM0D2 

T3 (3)  =  0.5* (T1 (3)  -  T2 (3) )  TGM0D2 

GO  TO  206  DAUX 

18  U1(2,J)  =  -U1(2,K)  DAUX 

T3(l)  =  -T2 ( 1)  TGM0D2 

T3  (3)  =  -T2  (3)  TGII0D2 

GO  TO  206  DAUX 

19  U1(2.J)  =  0.0  DAUX 

T3(l)  =  0.0  TGM0D2 

T3 (3)  =  0.0  TGM0D2 

206  IF(LPMI(J) .EQ.O)  GO  TO  207  TGM0D2 

CALL  MAT31 (DPMI (1,1 , J) ,T3 ,U2 ( 1 , J) )  TGM0D2 

GO  TO  20  TGM0D2 

207  U2 ( 1 , J)  =  T3(l)  TGM0D2 

U2 (2 , J)  =  T3 (2)  TGH0D2 

U2 (3, J)  =  T3 (3)  TGM0D2 

20  CONTINUE  TG1I0D2 

DAUX 

INITIALIZE  IJK  ABBA?  AND  IJ  COUNTEB  TO  ZEBO.  DAUX 

DAUX 

8  NQ2S  =  2*NS  ♦  NFLX  ♦  NO  DAUX 

NJ2  =  NQ2S  ♦  2*NJNT  DAUX 

IF  (NJ2.GT.54)  WBITE  (6,11)  NS , NFLX , NQ , NJNT , NJ2  DAUX 

11  FOBMAT ( ’ ONS= ' , 16 , ’ ,NFLX= ’ , 16 , ’ ,NQ= ’ , 16 , ’ ,NJNT= ’ , 16 , ’  AND  NJ2= ’ , I6/AFBEVS 

«’  THE  VALUE  OF  NJ2  EXCEEDS  THE  ABBA?  SIZES  FOB  BHS  AND  IJK  IN  SUBBDAUX 
«OUTINE  DAUX.  PBOGBAM  TEBMINATED. ’ )  DAUX 

IF  (NJ2.GT.54)  STOP  34  DAUX 

MJ2  =  NJ2  DAUX 

DO  10  1=1, NJ2  DAUX 

DO  10  J=1,NJ2  DAUX 

10  IJK(I.J)  =  0  DAUX 

IJ  =  0  DAUX 

DAUX 

ELMINATE  SEGLA  AND  MfEGD  FBOM  SYSTEM  OF  EQUATIONS.  DAUX 

DAUX 

IF  (NS. GT.O)  CALL  DAUX55  DAUX 

IF  (NJNT. EQ.O)  GO  TO  12  DAUX 

IF  (NFLX. GT.O)  CALL  DAUX44  DAUX 

CALL  DAUX1 1  DAUX 

CALL  DAUX 12  DAUX 

CALL  DAUX22  DAUX 

12  IF  (NQ.LE.O)  GO  TO  15  DAUX 

IF  (NJNT. EQ.O)  GO  TO  13  DAUX 

CALL  DAUX31  DAUX 

CALL  DAUX32  DAUX 

13  CALL  DAUX33  DAUX 

DO  14  1=1, NQ  DAUX 


14  IF  (XQTYPE(I) .GE.4)  MJ2  =  -NJ2  DAUX 

15  IF  (NPRT(8) . EQ.O)  GO  TO  28  DAUX 

21  WRITE  (6,22)  NPG, ( J , J= 1 ,NJ2)  PAGE 

NPG=NPG* 1  PAGE 

22  FORMAT ( ’  1  DAUX  PRINT  OF  IJK  MATRIX’ ,97X, ’PAGE’ , I5//6X, 4013)  PAGE 

DO  23  1=1, NJ2  DAUX 

23  WRITE  (6,24)  I , (IJK (I ,J) , J=1 ,NJ2)  DAUX 

24  FORMAT ( 13, 3X. 4013)  DAUX 

WRITE  (6,29)  DAUX 

29  FORMAT ( ' 0  DAUX  PRINT  OF  RHS  ARRAY’//)  DAUX 

DO  30  X=1,NJ2  DAUX 

30  WRITE  (6,27)  K, (RHS(I ,K) . 1=1 ,3)  DAUX 

WRITE  (6,25)  NPG  PAGE 

NPG=NPG+ 1  PAGE 

25  FORMAT ( ’ 1  DAUX  PRINT  OF  C  ARRAY  ELEMENTS' ,91X, ’PAGE’ ,15//)  PAGE 

DO  26  K= 1 , IJ  DAUX 

26  WRITE  (6,27)  K, ( (C (I ,J,K) ,J=1 ,3) ,1=1 ,3)  DAUX 

27  F0RMAT(I6,9G14.7)  DAUX 

28  IF  (NPBT(8) .EQ.-2)  GO  TO  31  DAUX 

C  DAUX 

C  SOLVE  SYSTEM  OF  EQUATIONS  FOR  F.TQ.QQ  &  V4.  DAUX 

C  DAUX 

CALL  FSMSOL  (C .RHS , IJK.MJ2 , IJ,54 ,600)  CHGIII 

IF  (NPRT(8).EQ.  2)  NPRT(8)  =  -2  DAUX 

IF  (NPRT (8) . EQ. -2)  GO  TO  21  DAUX 

31  IF  (NPRT(8) .EQ.-2)  NPRT(8)  =  0  DAUX 

EPS12  =  EPS (12)  JDRIFT 

IF  (NJNT.EQ.O)  GO  TO  49  DAUX 

DO  51  1=1, NJNT  DAUX 

NJ  =  NQ2S  +  I  DAUX 

NI  =  NJ+NJNT  DAUX 

DO  51  K= 1 ,3  DAUX 

IF  (DABS (RHS (K ,NJ) ) .LT.EPS12)  RHS(K.NJ)  =  0.0  DAUX 

IF  (DABS (RHS (K,NI)) .LT.EPS12)  RHS(K.NI)  *  0.0  DAUX 

TQ (K , I )  =  TQ(K.I)  -  RHS(K.NI)  DAUX 

51  F(K , I)  =  RHS(K.NJ)  DAUX 

49  IF  (NQ.EQ.O)  GO  TO  53  DAUX 

DO  52  1=1, NQ  DAUX 

J  =  2*NS  +  NFLX  +  I  DAUX 

DO  52  K=1 ,3  DAUX 

IF  ( KQTYPE ( I ) . LT . 0 )  RHS(K.J)  =  0.0  DAUX 

IF  (DABS (RHS (X,J) ) .LT.EPS12)  RHS(K,J)  =  0.0  DAUX 

52  QQ(K,I)  =  RHS(K.J)  DAUX 

53  IF  (NFLX. EQ.O)  GO  TO  70  DAUX 

DO  54  1=1, NFLX  DAUX 

J  =  2*NS  +  I  DAUX 

DO  54  K=1 ,3  DAUX 

IF  (DABS (RHS (K,J) ) .LT.EPS12)  RHS(K.J)  =  0.0  DAUX 

54  V4(K,I)  =  RHS (X , J)  DAUX 

C  DAUX 


BACKUP  SOLUTION  FOR  SEGLA  AND  MtEGD.  DAUX 

DAUX 

70  DO  71  J  =  1 , NGRND  DAUX 

DO  71  1=1,3  DAUX 

SEGLA  (I  ,J)  =  UKI.J)  DAUX 

71  WMEGD ( I , J )  =  U2 (I , J)  DAUX 

IF  (NS.EQ.O)  GO  TO  79  DAUX 

DAUX 

SET  UP  SEGLA  &  WMEGD  FOR  SINGULAR  SEGMENTS.  DAUX 

DAUX 

IS  =  0  DAUX 

DO  78  J=l, NGRND  DAUX 

IF  (ISING(J) . LE. 0)  GO  TO  78  DAUX 

IS  =  IS+2  DAUX 

DO  77  1=1,3  DAUX 

IF  (DABS(RHS(I , IS- 1) ) .LT.EPS12)  RHS(I.IS-l)  =  0.0  DAUX 

SEGLA (I , J)  =  SEGLA (I , J)  ♦  RHS(I.IS-l)  DAUX 

IF  (DABS(RHS(I .IS  ) ) . LT.EPS12)  RHS(I,IS  )  =  0.0  DAUX 

77  WMEGD (I , J)  =  WMEGD ( I , J )  ♦  RHS(I.IS)  DAUX 

78  CONTINUE  DAUX 

79  IF  (NJNT.EQ.O)  GO  TO  80  DAUX 

DAUX 

ELIMINATE  F  DAUX 

DAUX 

DO  75  M= 1 , NJNT  DAUX 

N  =  IABStJNT(M) )  DAUX 

IF  (N.EQ.O)  GO  TO  73  DAUX 

DO  72  1=1,3  DAUX 

DO  72  J= 1 , 3  DAUX 

aauLAd.N  )  =  SEGLA  (I  ,N  )  -  All  (I ,  J  ,M)  «RW(N  )»F(J,M)  SLIP 

SEGLA (I ,M+1)  =  SEGLA (I ,M+1)  ♦  A1 1 (I , J ,M) »RW(M+ 1) *F (J ,M)  SLIP 

WMEGD (I ,N)  =  WMEGD (I , N  )  -  B12(J , I , 2*M-1) *RPHI (I ,N  )*F(J,M)  DAUX 

72  WMEGD d , M+ 1 )  =  WMEGD d , M+ 1 )  -  B12(J,I,2*M  ) »RPHI (I ,M+ 1) «F( J ,M)  DAUX 

DAUX 

ELIMINATE  TQ  DAUX 

DAUX 

73  IF  (FREE(M) )  GO  TO  75  SLIP 

L  =  NQ2S  +  NJNT  ♦  M  DAUX 

DO  74  1=1,3  DAUX 

DO  74  J=1 ,3  DAUX 

WMEGD (I , N  )  =  WMEGD (I , N  }  -  A22 (I , J, 2»M- 1) »BPHI (I ,N  )*RHS(J,L)  DAUX 

74  WMEGD d , M+ 1 )  =  WMEGDd,M*l)  ♦  A22(I,J,2»M  ) »RPHI (I ,M+1) »RHS(J,L)  DAUX 

75  CONTINUE  DAUX 

80  IF  (NQ.EQ.O)  GO  TO  83  DAUX 

DAUX 

ELIMINATE  QQ  DAUX 

DAUX 

DO  82  K= 1 ,N0  DAUX 

IF  (KQTYPE(K) .LT.O)  GO  TO  82  DAUX 

N  =  KOI (K)  DAUX 


81 

82 

83 


M  =  KQ2 (K) 

DO  81  1=1,3 
DO  81  J= 1 , 3 

SEGLA(I.N)  =  SEGLA(I.M) 
SEGLA(I.M)  =  SEGLA(I.M) 
WMEGD ( I , N)  =  WMEGD(I.N) 
WMEGD ( I , M)  =  WMEGD ( I ,  M) 
CONTINUE 

IF  (NFLX.EQ.O)  GO  TO  90 


A13(I,J,2»K-1)*RW(H)  »QQ(  J ,K) 

A13 ( I ,  J ,  2*K  )»RW(M)  *QQ(J,K) 

A23 (I , J , 2*K- 1 ) »RPHI ( I ,N) *QQ( J , K) 
A23 (I , J , 2»K  ) »RPHI (I ,M) »QQ( J ,K) 


C 

C 

C 


84 

90 


91 


WMEGD (I ,N1) 
WMEGD (I ,N2) 
WMEGD (I ,N3) 


-  B42 (J , I , 3»N-2) »RPHI (I ,N1) »V4 (J,N) 

-  B42 ( J , I , 3»H- 1 ) »RPHI (I ,N2) *V4 (J , N) 

-  B42 (J , I , 3»N  ) *RPHI (I , N3) «V4 (J ,N) 


C 

C 

c 


ELIMINATE  V4  (TORQUES  FOR  FLEXIBLE  SEGMENTS) 

DO  84  N=1,NFLX 
N1  =  NFLEX(l.N) 

N2  =  NFLEX(2 ,N) 

N3  =  NFLEX(3 ,N) 

DO  84  1=1,3 
DO  84  J= 1 , 3 
WMEGD(I.Nl) 

WMEGD (I ,N2) 

WMEGD (I ,N3) 

DO  91  J  = 1 , NGRND 
DO  91  1=1,3 

IF  (DABS (WMEGD ( I, J) ) .LE.EPS12)  WMEGD(I.J)  =  0.0 
IF  (DABS(SEGLA(I , J) ) . LE.EPS12)  SEGLA(I.J)  =  0.0 

OPTIONAL  OUTPUT  OF  FUNCTIONS  AND  DERIVATIVES. 

IF  ( NPRT ( 9 ) . NE . 0 )  CALL  PRINT(6H  DAUX  ) 

CALL  ELTIME(2,9) 

RETURN 

END 


DAUX 

DAUX 

DAUX 

DAUX 

DAUX 

DAUX 

DAUX 

DAUX 

DAUX 

DAUX 

DAUX 

DAUX 

DAUX 

DAUX 

DAUX 

DAUX 

DAUX 

DAUX 

DAUX 

DAUX 

DAUX 

DAUX 

DAUX 

DAUX 

DAUX 

DAUX 

DAUX 

DAUX 

DAUX 

DAUX 

DAUX 

DAUX 

DAUX 


SUBROUT I ME  DAUX11  DAUX11 

REV  IV  07/24/86SLIP 

CALLED  BY  SUBROUTINE  DAUX  TO  COMPUTE  DAUX1I 

DAUX11 

-1  -I  DAUX11 

(C 1 1 )  =  (BID (M)  (All)  ♦  (B12) (PHI)  (A21)  DAUX11 

DAUX 11 

-1  -1  DAUX1 1 

(Rl)  =  (Bll)  (M)  (Ul)  +  (B12)  (PHI)  (U2)  -  (VI)  DAUX11 

DAUX 11 

IMPLICIT  REAL»8 (A-H.O-Z)  DAUX11 

COMMON/ COMTRL/  TIME, NSE6 , NJNT , NPL , NBLT , NBAG , NVEH , NGRND ,  DAUX 11 

«  US , HQ, USD , NFLX , NHHNSS , NWINDF , NJNTF , MPRT (36) . NPG  PAGE 

COMMON/ SGMNTS/  D(3,3,30) ,WMEG(3,30) ,WMEGD(3,30) ,U1(3,30) ,U2(3,30) .DAUXll 

*  SEGLP(3,30) ,SEGLV(3.30) ,SEGLA(3,30) ,NSYM(30)  DAUXll 

COMMON/DESCRP/  PHI (3.30) ,W(30) ,RW(30) ,SR(4,60) ,HA(3,60) ,HB(3,60) ,  SLIP 

«  RPHI (3,30) ,HT(3 ,3 ,60) , SPRIMG(5 ,90) , VISC (7 ,90) ,  DAUXll 

»  JNT(30) ,IPIN(30) ,ISING(30) ,TGL0B(30) ,J0IHTF(30)  DAUXll 

COMMON/CMATRX/  VK3.30) ,V2(3,30) ,V3(3,12) ,B12(3,3,60) ,A22(3,3,60) .DAUXll 
»  F(3,30) ,TQ(3,30) ,WJ(30) ,A11(3,3,30)  SLIP 

COMMON/TEMPVS/  C (3 , 3 ,600) ,RHS (3 ,54) , IJK(54 ,54) , IJ ,MQ2S  CHGIII 

•  ,DN(3,3) ,DM(3,3) ,SN(3,3) ,SM(3,3) ,HH(3,3) ,BN(3)  DAUXll 

CALL  ELTIME ( 1 , 14)  DAUXll 

DO  30  M= 1 , NJNT  DAUXll 

N  =  IABS ( JNT(M) )  DAUXll 

MQ  =  NQ2S  +  M  DAUXll 

IJ  =  IJ+1  DAUXll 

IJK(MQ.MQ)  =  IJ  DAUXll 

IF  (N.GT.O)  GO  TO  13  DAUXll 

DAUX1 1 

IF  (N  <  1)  SET  C11(M,M)  =  I  DAUXll 

DAUXll 

AND  RHS(M)  =  VI (M)  DAUXll 

DAUXll 

DO  12  1=1,3  DAUXll 

DO  11  J= 1 , 3  DAUXll 

11  C(I,J,IJ)  =  0.0  DAUXll 

C(I,I,IJ)  =  1.0  DAUXll 

12  RHS(I.MQ)  =  VI  (1,11)  DAUXll 

IJK(MQ.MQ)  =  -IJ  DAUXll 

GO  TO  30  DAUXll 

DAUXll 

IF  (N  >  0)  SET  RHS(M)  =  Ul (MI  -  UHM+l)  -  VI (M)  DAUXll 

♦  B12(M,N)U2(N)  ♦  B12 (M.M+ 1 ) U2 (M+ 1 )  DAUXll 

DAUXll 

AND  Cll(M.N)  =  RW(M)  ♦  RW(M+1)  DAUXll 

♦  B12(M,N  ) PHI (N  ) ‘ A21 (N  ,M)  DAUXll 

♦  B12 (M,M+ 1 ) PHI (M+ 1 ) ’A21(M+1,M)  DAUXll 

DAUXll 

13  DO  15  1=1,3  DAUXll 


WiCje 


m 


T1  =  -Vl(I.M) 

DO  15  J  =  1,3 

T1  =  T1  +  B12d,J,2»M-l)*U2(J,N)  ♦  B12 ( I , J , 2»M) *02 ( J ,M+ 1) 

*  +  A1 1  (I ,  J  ,M)  »  ( U 1  ( J ,  H)  -  UKJ.M+l)) 

IF  (J.LT.I)  00  TO  15 

T2  =  0.0 

IF  (J.EQ.I)  T2  =  RW(N)  +  RW(M+1) 

DO  14  K=1 ,3 

14  T2  =  T2  +  B12(I ,K,2#M-1) »RPHI (K,N  ) *B12(J,K,2#M-1) 

*  ♦  B12 ( I ,K , 2*M  ) »RPHI ( K , M+ 1)«B12(J,K, 2«M  ) 

Cd.J.IJ)  =  T2 

C(J,I,IJ)  =  T2 

15  RHS(I.MQ)  =  T1 

IF  dSING(N)  .NE.O)  GO  TO  30 
L  =  0 

IF  (N.GT.l)  L  =  IABS(JNT(N-1) ) 

IF  (L.EQ.O)  GO  TO  18 


C 

C 

C 

C 

c 

c 

c 

c 


IF  (N  >  1)  AND  (L  =  JNT(N-l)  >  0) 

SET  C11(M,N-1)  =  -RW(N)  +  B12 (M,N)PHI (N) ’A21 (N.N-l) 

T 


AND  Cll(N-l.M)  =  C(M,N-1) 


KJNT  =  NQ2S  +  N  -1 
IJ  =  IJ+1 
IJK(MQ.KJNT)  =  IJ 
IJK (KJNT, MQ)  =  IJ+1 
DO  17  1=1,3 
DO  17  J=  1 , 3 
C(I.J.IJ)  =  0.0 
DO  16  K=  1 , 3 
16  C(I.J.IJ) 


C(I,J,IJ)  ♦  B12(I,K,2»li-l)  «RPHI  (K,N)  *B12  ( J  ,K ,  2»N-2) 
-  A1 1 (I , K , M) *RW(N) *A1 1 ( J , K , N- 1 ) 


C 

C 

c 

c 

c 

c 


SET  Cll(M.L)  =  RW(N)  +  B12 (M.N)PHI (N) ’ A21 (N.L) 


AND  Cll(L.M) 
KJNT  =  NQ2S  ♦  L 


Cll(M.L) 


SLIP 

DAUX11 

DAUX11 

SLIP 

DAUX11 

DAUX11 

DAUX11 

DAUX11 

DAUX11 

DAUX11 

DAUXH 

DA0X11 

DAUX11 

DAUX1 1 

DAUX11 

DAUX11 

DAUX1 1 

DAUX11 

DAUX11 

DAUX1 1 

DAUX11 

DAUX11 

DAUX1 1 

DADX11 

DAUX11 

DACTXII 

DAUX1 1 

DAUX1 1 

DAUX11 

DAUX11 

DAUX1 1 

DAUX11 

DAUX1 1 

DAUX11 

SLIP 


17  C (J , I , IJ+1)  =  C(I,J,IJ) 

DADX11 

• 

IJ  =  IJ+1 

DAUX11 

18  IF  (M.EQ.NJNT)  GO  TO  30 

DAUX1 1 

Ml  =  M+l 

DAUX11 

^■Ji' 

f-y- 

DO  21  L=M1 , NJNT 

DAUX11 

•  v  • 

m 

IF  (IABS (JNT (L) ) . NE . N)  GO  TO  21 

DAUX1 1 

C 

DAUX1 1 

ViC- 

• 

C  IF  (L  >  M)  AND  (JNT(L)  =  N) 

DAUX11 

DAUX1 1 
DAUX1 1 
DAUX1 1 
DAUX1 1 
DADX1 1 
DAUX1 1 
DAUX11 


■MMMmmmmwmmMi 
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IJ  =  IJ  +  1  DAUX1 1 

IJK(MQ,XJNT)  =  IJ  DAUX1 1 

IJK(KJNT .HQ)  =  IJ+1  DAUX11 

DO  20  1=1,3  DAUX11 

DO  20  J=1 ,3  DAOXI1 

C(I.J,IJ)  =  0.0  DAUX1 1 

DO  19  K=1 ,3  DAUX11 

19  C(I,J,IJ)  =  Cd.J.IJ)  +  B12(I  ,K,  2*11-1)  «BPHI  (K,H)  «B12(J,K,2«L-1)  DADX11 

*  ♦  All (I , K , M) *BW(H) *A1 1 ( J ,K ,L)  SLIP 

20  C(J,I,IJ+1)  =  C(I(J.IJ)  DADX11 

IJ  =  IJ+1  DAUX11 

21  COMTIMUE  DAUX1 1 

30  CONTINUE  DAUX11 

CALL  ELTIME(2 , 14)  DAUX11 

RETURN  DAUX11 

END  DAUX11 


SUBROUTINE  DAUX 12  DAUX12 

REV  IV  07/24/B6SLIP 

CALLED  BY  SUBROUTINE  DAUX  TO  COMPUTE  DAUX12 

DAUXI2 

-1  DAUX 12 

(C12)  =  (B12) (PHI)  (A22)  DAUX 12 

DAUX12 

T  DAUX 12 

(C21)  =  (C12)  DAUX12 

DAUX 12 

IMPLICIT  REAL*8 (A-H.O-Z)  DAUX 12 

COMMON/CONTRL/  TIME , NSEG , NJNT , NPL , NBLT , NBAS , WEB , NORND ,  DAUX 12 

»  NS , NQ , NSD , NFLX , NHRNSS , NWINDF , NJNTF , NPRT ( 36 ) , NPG  PAGE 

COMMON/DESCRP/  PHI(3,30) ,W(30) ,RW(30) ,SR(4,60) ,HA(3,60) ,HB(3,60) .  SLIP 

*  RPHI (3,30) ,HT(3 ,3,60) .SPRING (5 ,00) , VISC (7,90) ,  DAUX 12 

«  JNTC30) ,IPIN(30) ,ISIHG(30) ,IGL0B(30) ,J0INTF(30)  DAUX 12 

COMMON/CMATRX/  Vl(3,3 0) ,V2(3,30) ,V3(3,12) ,B12(3,3,60) ,A22(3,3,60) , DAUX 12 
»  F (3,30) , TO (3 ,30) , WJ (30) ,A1 1 (3,3,30)  SLIP 

LOGICAL* 1  FREE  SLIP 

COMMON/TEMPVS/  C(3,3,600) ,RHS(3,54) ,IJK(54,54) ,IJ,NQ2S  CHGIII 

*  ,DN(3,3) ,DM(3,3) ,SN(3,3) ,SM(3,3) ,HH(3,3) ,BN(3)  DAUX 12 

«  , IDUM(362) .FREE (30)  SLIP 

CALL  ELTIME ( 1 . 15)  DAUX 12 

NQSJNT  =  NQ2S  +  NJNT  DAUX12 

DO  60  M= 1 , NJNT  DAUX 12 

N  =  IABS (JNT(M) )  DAUX 12 

IF  (N.EQ.O)  GO  TO  60  DAUX12 

MQ  =  NQ2S  +  M  DAUX 12 

IF  (FREE (Ml)  GO  TO  37  SLIP 

MJNT  =  NQSJNT  +  M  D.UX12 

IJ  =  IJ+1  Dmi2 

IJK(MQ.MJNT)  =  IJ  DA  ’XI 2 

IJX (MJNT.MQ)  =  IJ+1  DAI >12 

DO  36  1=1,3  DAU.  12 

DO  36  J=1 ,3  DAUX1. 2 

SN(I , J)  =  0.0  DAUX. 2 

SM( I , J)  =  0.0  DAUX 12 

DO  35  K=1 ,3  DAUX 12 

SN(I ,  J)  =  SN( I ,  J)  +  B 1 2 ( I  ,K,2*M-1)  *  RPHKK.N  )  *  A22(K,J,2*M-1)  DAUX  12 

35  SM( I , J)  =  SM( I , J)  ♦  B 1 2 ( I ,K,2*M  )  *  RPHI(K,M+1)  »  A22(K,J,2»M  )  DAUX 12 

C(I.J,IJ  )  =  SN(I.J)  -  SM(I,J)  DAUX 12 

36  C(J,I,IJ+1)  =  C(I,J,IJ)  DAUX 12 

IJ  =  IJ+1  DAUX 12 

37  IF  (ISING(N) .NE.O)  GO  TO  50  DAUX12 

IF  (N.EQ.l)  GO  TO  43  DAUX 12 

IF  (FREE(N-l) )  GO  TO  43  SLIP 

MJNT  =  NQSJNT  ♦  N-l  DAUX 12 

IJ  =  IJ+1  DAUX12 

IJK(MQ.MJNT)  =  IJ  DAUX 12 

IJK (MJNT.MQ)  =  IJ+1  DAUX12 


DO  42  1=1.3 
DO  42  J=1 ,3 
SM(I.J)  =  0.0 
DO  41  K= 1 ,3 

41  SM(I.J)  =  SM(I,J)  ♦  B 1 2 ( I  ,K, 2*11-1) 
Cd.J.IJ  )  =  -SN(I,J) 

42  C(J,I,IJ+1)  =  -Slid ,  J) 

IJ  =  IJ+1 

43  DO  49  L=N,MJIIT 

IF  (L.EQ.If)  GO  TO  49 

IF  (IABS(JNT(L) ) .NE.N  )  GO  TO  49 

IF  (FREE(L) )  GO  TO  49 

MJNT  =  NQSJNT  ♦  L 

IJ  =  IJ+1 

IJKOfQ  .IUHT)  =  IJ 

IJK(MJNT.MQ)  =  IJ+1 

DO  48  1=1,3 

DO  48  J=1 ,3 

SMd.J)  =  0.0 

DO  47  K=1 ,3 

47  SN(I,J)  =  SN(I,J)  +  B 12 ( I , K , 2»M- 1 ) 
Cd.J.IJ  )  =  SN(I.J) 

48  C(J.I,IJ+1)  =  SH(I.J) 

IJ  =  IJ  +1 

49  CONTINUE 

50  IF  (M.EQ.NJNT)  GO  TO  60 

IF  (ISING(M+1) .NE.O)  GO  TO  60 

Ml  =  M+l 

DO  j9  L=M1 ,  NJNT 

IF  (IABS (JNT(L) ) .NE.M1)  GO  TO  59 

IF  (FREE (L) )  GO  TO  59 

MJNT  =  NQSJNT  ♦  L 

IJ  =  IJ+1 

IJK (MQ, MJNT)  =  IJ 

IJK(MJNT.MQ)  =  IJ+1 

DO  58  1=1,3 

DO  58  J=1 ,3 

SM(I,J)  =  0.0 

DO  57  K=1 ,3 

57  SMd.J)  =  SM(I.J)  +  B12  (I  ,K,2»M  ) 

C(I,J,IJ  )  =  SM(I,J) 

58  C(J,I.IJ+1)  =  SM(I,J) 

IJ  =  IJ  +1 

59  CONTINUE 

60  CONTINUE 

CALL  ELTIME(2 , 15) 

RETURN 

END 


DAUX12 

DAUX12 

DAUX12 

DAUX12 

«  RPHKK.N  )  •  A22 (K , J , 2»N-2)  DAUX12 

DAUX12 

DAUX12 

DAUX12 

DAUX12 

DAUX12 

DAUX12 

SLIP 

DAUX12 

DAUX12 

DAUX12 

DAUX12 

DAUX12 

DAUX12 

DAUX12 

DAUX12 

*  RPHKK.N  )  «  A22 (K . J , 2»L- 1 )  DAUX12 

DAUX12 

DAUX12 

DAUX12 

DAUX12 

DAUX12 

DAUX12 

DAUX12 

DAUX12 

DAUX12 

SLIP 

DAUX12 

DAUX12 

DAUX12 

DAUX12 

DAUX12 

DAUX12 

DAUX12 

DAUX12 

»  RPHKK.M+l)  *  A22(K,J,2*L-1)  DAUX12 

DAUX12 

DAUX12 

DAUX12 

DAUX12 

DAUX12 

DAUX12 

DAUX12 

DAUX12 
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SUBROUTINE  DAUX22 


REV  IV 


DAUX22 

07/24/86SLIP 


c 

CALLED  BY 

SUBROUTINE  DAUX  TO 

COMPUTE 

DAUX22 

c 

DAUX22 

c 

DAUX22 

c 

-1 

DAUX22 

c 

(C22) 

=  (B22) (PHI)  (A22) 

-  (B24) 

DAUX22 

c 

DAUX22 

c 

-1 

DAUX22 

c 

(R2) 

=  (B22) (PHI)  (U2) 

-  (V2) 

DAUX22 

c 

IMPLICIT 

REAL* 8 (A-H.O-Z) 

DAUX22 

DAUX22 

COmaON/CONTRL/  TIME , NSEQ , NJNT , HPL , HBLT , NBAS , NVEH , NGRND ,  DAUX22 

«  MS ,  NQ ,  NSD ,  MFLX , NHRMSS , NWINDF ,  HJHTF ,  1IPRT  (36)  , MPQ  PAGE 

COMMON/SGMNTS/  0(3,3,30) ,IMEG(3,30) ,WMEGD(3,30) ,U1(3,30) ,U2(3,30) , DAUX22 
«  SEGLP(3,30) ,SEGLV(3,30) ,SEGLA(3,30) ,NSYM(30)  DAUX22 

COMMON/DESCRP/  PHI (3,30) ,W(30) ,RW(30) ,SR(4,60) ,HA(3,60) ,HB(3,60) ,  SLIP 
«  RPHI (3,30) ,HT(3, 3,60) ,SPRIMG(5 .90) ,VISC(7, 90) ,  DAUX22 

«  JNT(30) ,IPIN(30) ,ISING(30) ,IGLOB(30) ,J0INTF(30)  DAUX22 

COMMON/CMATRX/  VI (3,30) ,V2(3,30) ,V3(3,12) ,B12(3,3,60) ,A22(3,3,60) , DAUX22 
»  F(3,30) ,TQ(3,30) ,HJ(30) ,A11(3,3,30)  SLIP 

COMMON/CEULER/  IEULER(30) ,HIR(3,3,90) ,ANG(3,30) ,AMGD(3,30) ,  JDRIFT 

»  FE(3,30) ,TQE(3,30) .CONST (5, 30)  JDRIFT 

LOGICAL* I  FREE  SLIP 

COMMON/TEMPVS/  C(3, 3,600) ,RHS(3,54) ,IJK(54,54) .IJ.NQ2S  CHGIII 

»  ,DN(3,3) ,DM(3,3) ,SN(3,3) ,SM(3,3) ,HH(3,3) ,BN(3)  DAUX22 

»  , IDUM(362) .FREE (30)  SLIP 

LOGICAL  TEST  DAUX22 

CALL  ELTIME( 1 , 16)  DAUX22 

NQSJNT  *  NQ2S  +  NJNT  DAUX22 

DO  90  M= 1 , NJNT  DAUX22 

MJMT  =  NQSJNT  +  M  DAUX22 

ro  60  1=1,3  DAUX22 

60  RHSd.MJNT)  =  V2(I,M)  DAUX22 

N  =  IABS (JNT(M) )  DAUX22 

IF  (N.EQ.O)  GO  TO  90  DAUX22 

IF  (FREE(M) )  GO  TO  90  SLIP 

IJ  =  IJ+1  DAUX22 

I JK (MJMT , MJNT)  =  IJ  DAUX22 

DO  61  J=1 ,3  DAUX22 

DO  61  1=1,3  DAUX22 

61  HH(I,J)  =  0.0  DAUX22 

LGO  =  IPIN(M)+8  SLIP 

TEST  =  .FALSE.  DAUX22 

GOTO  (64,64,64,62,64,64,64,64,63,64,64,64,64,63,63) , LGO  SLIP 

62  IF  (IEULER(M) .GE.7)  GO  TO  64  DAUX22 

TEST  =  IEULER(M) . LT.4  DAUX22 

63  AN  =  0.0  DAUX22 

DO  51  J= 1 ,3  DAUX22 

51  AN  =  AN  +  HB(J,2*M-1) **2  *  RPHKJ.N  )  DAUX22 


«  ♦  HB(J,2«M  )««2  «  BPHI (J,M+1) 

IF  (TEST)  GO  TO  64 

CALL  DOT3I  (D(l , 1 ,N) ,HB(1 , 2»M-1) ,BN) 

DO  53  J=l,3 
DO  53  1=1,3 

53  HH(I , J)  =  AN*BH(I) «BN(J) 

64  DO  67  1=1,3 
RHS(I,MJNT)  =  -V2 ( I , M) 

DO  66  J=1 ,3 

RHS(I,MJNT)  =  RHSd.HJMT)  4  A22  ( J ,  1 , 2*M- 1 )  *U2  ( J ,  N  ) 

»  -  A22 (J , I , 2*M  ) »D2 (J ,M+ 1) 

SM(I,J)  =  0.0 
IF  (TEST)  GO  TO  66 
DO  65  K=1 ,3 

65  SN(I,J)  =  SH(I,J)  4  A22  (K ,  1 ,2*M- 1 )  «  RPHHK.N  )  •  A22(K,  J,2«M-1) 

«  4  A22(K,I,2*M  )  «  RPHI(K,M4l)  «  A22(K,J,2»M  ) 

66  C(I,J,IJ)  =  SNd.J)  4  HH(I.J) 

67  IF  (TEST)  C(I,I,IJ)  =  AN 

IF  (ISING(N) . NE.O)  GO  TO  90 
IF  (N.EQ.l)  GO  TO  80 
IF  (FREE(N-l) )  GO  TO  80 
N1JNT  =  NQSJNT  4  N  -1 
IJ  =  I J4 1 

IJKdUNT.NIJNT)  =  IJ 
IJK(NIJNT.MJNT)  =  I J+ 1 
DO  77  1=1,3 
DO  77  J-1,3 
SN(I,J)  =  0.0 
DO  76  K=1 ,3 

76  SN(I.J)  =  SNd.J)  4  A22(K,I,2«M-1)  *  BPHKK.N  )  *  A22(X,J,2«N-2) 
C(I,J,IJ)  =  -SNd.J) 

77  C ( J , I , I J4 1 )  =  -SN(I.J) 

IJ  =  IJ41 

80  IF  (M.EQ.NJNT)  GO  TO  90 
Ml  =  M41 

DO  88  L=M1 ,NJNT 
IF  (IABS(JNT(L) ) . NE.N)  GO  TO  88 
IF  (FREE(L) )  GO  TO  88 
LJNT  =  NQSJNT  4  L 
IJ  =  I J4 1 

I JK (MJNT.LJNT)  =  IJ 
IJK(LJNT.IUNT)  =  I J4 1 
DO  87  1=1,3 
DO  87  J=1 ,3 
SN(I,J)  =  0.0 
DO  86  K=  1 ,3 

86  SN(I,J)  =  SN(I,J)  4  A22(K,1 ,2*M-1)  *  RPHKK.N  )  •  A22(K,J,2«L-1) 
C(I,J,IJ)  =  SN(I,J) 

87  C(J,I,IJ4l)  =  SN(I , J) 

IJ  =  I J4 1 


DAUX22 

DAUX22 

DAUX22 

DAUX22 

DAUX22 

DAUX22 

DAUX22 

DAOX22 

DADX22 

DAUX22 

DAUX22 

DAUX22 

DAUX22 

DAUX22 

DAUX22 

DAUX22 

DAUX22 

DAUX22 

DAUX22 

DAUX22 

SLIP 

DADE22 

DAUX22 

DAUX22 

DAUX22 

DADX22 

DAUX22 

DAUX22 

DAUX22 

DAUX22 

DAUX22 

DAUX22 

DADX22 

DADX22 

DAUX22 

DADX22 

DAUX22 

SLIP 

DAUX22 

DAUX22 

DAUX22 

DAUX22 

DAUX22 

DADX22 

DAUX22 

DAUX22 

DAUX22 

DAUX22 

DAUX22 

DAUX22 


88  COHTIMUE 
90  COMTIHUE 

CALL  ELTIlfE (2 , 16) 

RETURM 

EHD 
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DA0X22 

DA0X22 

DAOX22 

DA0X22 

DAUX22 


% 


i 


\v 

\v 
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SUBROUTINE  DAUX31 

DAUX31 

c 

REV  IV 

07/24/86SLIP 

c 

CALLED  BY  SUBROUTINE  DAUX 

TO  COMPUTE 

DAUX31 

c 

DAUX31 

c 

-1 

- 

1 

DAUX31 

c 

(C13)  =  (Bll) (M)  (A13)  + 

(B12) (PHI) 

(A23) 

DAUX31 

c 

DAUX31 

c 

-1 

- 

1 

DAUX31 

c 

(C 31)  =  (B31) (M)  (All)  * 

(B32) (PHI) 

(A21) 

DAUX31 

c 

DAUX31 

IMPLICIT  REAL *8  (A-H.O-Z) 

DAUX31 

COMMON/ CONTEL/  TIME , VSEG , NJNT , NPL , MBLT , NBAG , HVEH , NGRND ,  DAUX31 

*  NS , HQ , USD , NFLX , NHRNSS , NWI NDF , MJNTF , NPBT ( 36 ) , NPG  PAGE 

COMMON/DESCRP/  PHK3.30)  ,»(30)  ,BW(30)  ,SB(4,60)  .HA(3,60)  ,HB(3,60)  ,  SLIP 

»  RPHK3.30)  ,HT(3,3,60)  ,  SPBING(5 ,90)  ,VISC(7,90)  ,  DAUX31 

*  JUT (30) ,IPIM(30) ,ISINQ(30) ,IGLOB(30) ,J0INTF(30)  DAUX31 

COMMON/ CMATBX/  VI (3.30) ,V2(3,30) ,V3(3,12) ,B12(3,3,eO) ,A22(3,3.60) .DAUX31 

«  F (3 , 30)  ,TQ (3 ,30)  , WJ (30)  , A1 1  (3 ,3 ,30)  SLIP 

COMMON/CSTBNT/  A13(3,3,24) ,A23(3,3,24) ,B31 (3,3,24) ,B32(3,3,24) ,  DAUX31 

»  HHT(3,3, 12) , BK1 (3 , 12) ,8X2(3,12) ,QQ(3,12) ,TQQ(3,12) .DA0X31 


»  BQQ (3,12) , HQQ (3 , 12) ,SQQ(12) ,CFQQ(12) , 

»  KQ 1(12) ,KQ2(12) ,KQT7PE(12) 

COMMON/TEMPVS/  0(3,3,600) ,BHS(3,54) ,IJK(54,54) .IJ.NQ2S 
CALL  ELTIME(1.17} 

DO  30  N=1,NQ 

IF  (KQTYPE(N) .LT.O)  GO  TO  30 
K1  =  KQKN) 

K2  *  KQ2(N) 

NNS  =  NQ2S  -  NQ  ♦  N 
IF  (Kl.LE.l)  GO  TO  13 
IF  (IABS(JNT(K1-1) ) . EQ.O)  GO  TO  13 
IF  (ISING(Kl) .NE.O)  GO  TO  13 


C13(K1-1,N)  =  B11(K1-1,K1)M  (K1)A13(K1 ,N) 

-1 

♦  B12(K1-1 ,X1)PHI  (XI ) A23 (XI ,N) 


C3KN.K1-1)  =  B3KN.KDM  (Xl)All  (XI  ,X1-1) 

-1 

+  B32(N,K1)PHI  (XI) A21 (XI , K 1  —  1 ) 

MQ  =  NQ2S  ♦  XI  -  1 
IJ  =  IJ+1 
I JK  (MQ ,  NNS)  =  IJ 
IJK(NNS.MQ)  =  I J+ 1 
DO  12  1=1,3 
DO  12  J=1 ,3 
SUM  =  0.0 


DAUX31 

DAUX31 

CHGIII 

DAUX31 

DAUX31 

DAUX31 

DAUX31 

DAUX31 

DAUX31 

DAUX31 

DAUX31 

DAUX31 

DAUX31 

DAUX31 

DAUX31 

DAUX31 

DAUX31 

DAUX31 

DAUX31 

DAUX31 

DAUX31 

DAUX31 

DAUX31 

DAUX31 

DAUX31 

DAUX31 

DAUX31 

DAUX31 

DAUX31 

SLIP 


f 

I 


TOM  =  0.0 

SLIP 

DO  11  X*  1 ,3 

DA0X31 

SUM  =  SOM  ♦  B12(I,K,2*Kl-2) *BPHI (K ,K1) »A23 (K, J , 2»H- 1  ) 

DA0X31 

*  -  A 1 1 ( I ,K,K1- 1 ) *RW(K1) *A13 (X , J , 2*H- 1) 

SLIP 

11 

TUM  =  TUM  ♦  B32(I ,K,2«H-1  ) *RPHI (K,K1) »B12 (J ,K,2«Kl-2) 

DAUX31 

»  -  B31 (I ,K,2*H-1)*RW(K1) •A11(K,J,K1-1) 

SLIP 

C(I.J.IJ)  =  SOM 

DA0X31 

12 

Cd.J.IJ+l)  =  TOM 

DA0X31 

IJ  =  IJ+1 

DAUX31 

13 

IF  (K2.LE.1)  GO  TO  16 

DA0X31 

IF  (IABS(JNT(K2-1) ) . EQ.O)  GO  TO  16 

DAUX31 

IF  (ISIHG(K2) .NE.O)  GO  TO  16 

DA0X31 

c 

DAUX31 

c 

-1 

DAUX31 

c 

C13(K2-1 ,N)  -  Bll (K2-1 ,K2)M  (X2)A13(X2,N) 

DAUX31 

c 

-1 

DA0X31 

c 

♦  B12 (K2-1 ,K2) PHI  (X2)A23(K2,M) 

DAUX31 

c 

DAUX31 

c 

-1 

DA0X31 

c 

C31 (N.X2-1)  *  B31 (N,K2)M  (X2) All (X2.X2-1) 

DA0X31 

c 

-1 

DAUX31 

c 

♦  B32 (M,K2) PHI  (X2) A21 (X2 ,X2-1) 

DA0X31 

c 

DAUX31 

MQ  =  NQ2S  +  K2  -  1 

DA0X31 

IJ  =  IJ+1 

DAUX31 

IJK(MQ.MNS)  =  IJ 

DAUX31 

IJKCNNS ,MQ)  =  IJ+1 

DA0X31 

DO  15  1*1,3 

DA0X31 

DO  15  J=1 ,3 

DAUX31 

SUM  =  0.0 

SLIP 

TOM  =  0.0 

SLIP 

DO  14  X=1 ,3 

DAUX31 

SOM  *  SOM  ♦  B 1 2 ( I ,X , 2»X2-2) *RPHI (X,X2) »A23(X, J ,2«N  ) 

DAUX31 

«  -  A 1 1 ( I , X ,X2-1) *BW(X2) *A13 (X, J,2*H) 

SLIP 

14 

TUM  =  TUM  +  B32(I ,K,2*N  ) «BPHI (X ,X2) «B12 (J ,X, 2*X2-2) 

DAUX31 

*  -  B31 (I ,K,2*10  kBW(X2) *A11 (X, J,X2-1) 

SLIP 

C(I,J,IJ)  =  SUM 

DAUX31 

15 

C(I,J.IJ+1)  =  TUM 

DA0X31 

IJ  =  IJ+1 

DAUX31 

16 

IF  (WJMT.LE.O)  GO  TO  30 

DA0X31 

DO  26  L*1,NJNT 

DA0X31 

IF  (IABS(JHT(L) ) .ME.K1)  GO  TO  21 

DA0X31 

IF  (ISING(Kl) .NE.O)  GO  TO  21 

DAUX31 

c 

DA0X31 

c 

FOB  AMY  L  SUCH  THAT  JHT(L)  =  XI 

DAUX31 

c 

DAUX31 

c 

-1 

DA0X31 

c 

C 13  (L , N)  *  B1KL.XDM  (XI)  A13(X1  ,H) 

DA0X31 

c 

-1 

DA0X31 

c 

♦  B12(L,X1)PHI  (XI) A23(X1 , I) 

DAUX31 
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C31(M,L)  =  B31 (H,K1)M  (Kl)  All  (K1  ,L) 

-1 

♦  B32  (M.Kl)PHI  (K1)A21(K1,L) 

MQ  =  HQ2S  ♦  L 

IF  ( I JK (MQ , HHS) .HE.O)  QO  TO  18 

IJ  =  IJ+1 

IJK(MQ.MMS)  *  IJ 

IJK(HNS ,MQ)  =  IJ+1 

DO  17  J=1 ,3 

DO  17  1=1,3 

Cd.J.IJ  )  =  0.0 

17  C(I,J,IJ+1)  =  0.0 
IJ  =  IJ+1 

18  JJ  =  IJK(MQ,MIS) 

DO  20  1=1,3 

DO  20  J=1 ,3 
SOM  =  C(I,J,JJ) 

TOM  =  Cd.J.JJ+l) 

DO  19  K=1 ,3 

SOM  =  SOM  +  B12 (I , K , 2*L- 1) »BPHI (X,K1) «A23 (K, J ,2»H- 1) 
«  +A11 d ,K,L) »BW(K1 ) *A13 (X , J ,2»M-1) 

19  TOM  =  TOM  ♦  B32 (I , K , 2+H-l) *BPHI (K ,K1) «B12 (J ,K,2*L-1) 

*  +B31 (I ,K , 2*H- 1) *BW(K1) *A1 1 (J ,K ,L) 

C(I.J.JJ)  =  SOM 

20  C(I.J,JJ+1)  =  TOM 

21  IF  ( IABS (JUT (L) ) . ME . K2)  00  TO  20 
IF  dSIHG(K2)  .HE.O)  00  TO  26 

FOB  AMY  L  SOCH  THAT  JMT(L)  =  K2 


C13 (L ,H)  =  Bll (L,K2)M  (K2) A13 (K2 ,H) 

-1 

+  B12 (L ,K2) PHI  (K2)A23(K2,M) 


C3KM.L)  =  B31  (M ,K2)  M  (K2)  All  (K2 ,L) 

-1 

+  B32(M,K2)PHI  (K2) A21 (K2 ,L) 
MQ  =  MQ2S  +  L 

IF  (IJK(MQ,NMS) .NE.O)  00  TO  23 
IJ  =  IJ+1 
IJK(MQ.MMS)  =  IJ 
IJK(MMS.MQ)  =  IJ+1 
DO  22  J=1 ,3 
DO  22  1=1,3 


DAUX31 

DA0X31 

DA0X31 

DA0X31 

DA0X31 

DA0X31 

DA0X31 

DA0X31 

DA0X31 

DA0X31 

DA0X31 

DA0X31 

DA0X31 

DA0X31 

DA0X31 

DA0X31 

DA0X31 

DA0X31 

DA0X31 

SLIP 

SLIP 

DA0X31 

DAUX31 

SLIP 

DA0X31 

SLIP 

DA0X31 

DAUX31 

DA0X31 

DA0X31 

DA0X31 

DA0X31 

DA0X31 

DA0X31 

DA0X31 

DA0X31 

DA0X31 

DA0X31 

DA0X31 

DA0X31 

DA0X31 

DA0X31 

DA0X31 

DA0X31 

DA0X31 

DA0X31 

DAJX31 

DA0X31 

DA0X31 

DA0X31 


re*#;*: 


mm 


C(I,J,IJ  )  =  0.0  DA0X31 

22  C(I,J,IJ+1)  =  0.0  DA0X31 

IJ  =  IJ+l  DAOX31 

23  JJ  =  IJXtMQ.MMS)  DA0X31 

DO  25  1*1,3  DA0X31 

DO  25  J=1 ,3  DA0X31 

SOM  =  C(I.J.JJ)  SLIP 

TOM  =  C(I,J,JJ+1)  SLIP 

DO  24  K=1 ,3  DA0X31 

SOM  =  SOM  ♦  B12 (I , X , 2»L- 1) «RPHI (K,K2) «A23 (X, J ,  2«N  )  DA0X31 

#  ♦  A11(I,X,L)*BW(X2)»A13(X,J,2*M)  SLIP 

24  TOM  =  TOM  ♦  B32(I,X,2»H  ) *BPHI (K.K2) *B12(J,X,2*L-1)  DA0X31 

•  «  B31  (I  ,K , 2*11)  *RW(K2)  »A1 1  (J  ,K ,L)  SLIP 

C(I.J.JJ)  *  SOM  DA0X31 

25  C(I,J,JJ+1)  =  TOM  DA0X31 

26  CONTI NOE  DA0X31 

30  CONTINUE  DA0X31 

CALL  ELTIME(2 , 17)  DA0X31 

RETOBH  DA0X31 

END  DA0X31 


SUBBOUT I HE  DAUX32  DAUX32 

C  REV  IV  07/24/86SLIP 

C  CALLED  BY  SUBROUTINE  DAUX  TO  COMPUTE  DAUX32 

C  DAUX32 

C  - 1  DAUX32 

C  (C23)  *  (B22) (PHI)  (A23)  DAUX32 

C  DAUX32 

C  -1  DAUX32 

C  (C32)  =  (B32) (PHI)  (A22)  DAUX32 

C  DAUX32 

IMPLICIT  REAL* 8  (A-H.O-Z)  DAUX32 

COMMON/ COST BL/  TIME , NSEG , HJNT , NPL , MBLT , NBAQ , NVEH , MGRMD ,  DAUX32 

*  NS , NQ , NSD , NFLX , NHRNSS , NWINDF , NJNTF , NPBT ( 38 ) , VPQ  PAGE 

COMMON/ DESCRP/  PHI (3,30) ,W(30) ,RW(30) ,SR(4,60) ,HA(3,60) ,HB(3.60) ,  SLIP 

*  RPHI(3,30) ,HT(3,3,60) , SPEIH3(5 ,90) ,VISC(7,90) ,  DAUX32 

*  JNT(30) ,IPIN(30) ,ISING(30) ,IQLOB(30) ,JOINTF(30)  DAUX32 

COMMON/CMATRX/  VI (3,30) ,V2(3,30) ,V3(3,12) ,B12(3,3,60) ,A22(3,3,60) , DAUX32 

*  F(3,30) , TQ (3, 30) , WJ (30) ,A11 (3,3,30)  SLIP 

COMMON/CSTRNT/  A13(3,3,24) ,A23(3,3,24) ,B31 (3,3,24) ,B32(3,3,24) .  DAUX32 

*  HHT(3,3, 12) ,RK1 (3 , 12) ,RK2(3,12) ,QQ(3,12) ,TQQ(3,12) , DAUX32 

*  RQQ(3,12) ,HQQ(3,12) ,SQQ(12) ,CFQQ(12) ,  DAUX32 

*  KQ1 (12) ,KQ2(I2) ,KQTYPE(I2)  DAUX32 

LOGICAL* 1  FREE  SLIP 

COMMOH/TEMPVS/  0(3,3,800) ,RHS(3,54) ,IJK(54.54) ,IJ,HQ2S  CHGIII 

*  ,DN(3,3) ,DM(3,3) , BN ( 3 ) , IDUM(416) .FREE (30)  SLIP 

CALL  ELTIMEd  ,  18)  DAUX32 

NQSJNT  *  NQ2S  ♦  NJNT  DAUX32 

DO  60  Ns 1 , NQ  DAUX32 

IF  (KQTYPE(N) .LT.O)  GO  TO  80  DAUX32 

K1  *  KQKN)  DAUX32 

K2  =  KQ2 (N)  DAUX32 

HNS  =  NQ2S  -  HQ  +  N  DAUX32 

IF  (Kl.LE.l)  GO  TO  43  DAUX32 

IF  (IABS(JNT(X1-1) ) .EQ.O)  GO  TO  43  DAUX32 

IF  (FREE(Kl-l))  GO  TO  43  SLIP 

IF  (ISING(Kl) .NE.O)  GO  TO  43  DAUX32 

C  DAUX32 

C  -1  DAUX32 

C  C23(K1-1 ,N)  =  B22 ( K 1 - 1 ,K1)PHI  (Kl) A23 (K1 ,N)  DAUX32 

C  DAUX32 

C  -1  DAUX32 

C  C32 (N.KI-l)  *  B32(N,K1)PHI  (Kl) A22 (Kl ,KI-1)  DAUX32 

C  DAUX32 

KJNT  =  NQSJNT  ♦  Kl  -  1  DAUX32 

IJ  =  IJ+1  DAUX32 

IJK(KJNT.NNS)  =  IJ  DAUX32 

IJK(HNS.KJNT)  =  IJ*1  DAUX32 

DO  42  1*1,3  DAUX32 

DO  42  J=1 ,3  DAUX32 

SUM  =  0.0  DAUX32 


TUM  =0.0  DAUX32 

DO  41  K= 1 , 3  DAOX32 

SUM  =  SUM  ♦  A22(K,I ,2*Kl-2)  »  BPHI(K.Kl)  «  A23(K,J,2«H-1  )  DAUX32 

41  TUM  =  TUM  ♦  B32 ( I ,K,2»N-1  )  «  BPHI(K.Kl)  •  A22 (K , J , 2 » K 1 - 2 )  DAUX32 

C(I,J,IJ  )  =  -SUM  DAUX32 

42  ca.J.IJ+1)  =  -TUM  DAUX32 

IJ  =  IJ+ 1  DAUX32 

43  IF  (K2.LE.1)  GO  TO  48  DAUX32 

IF  (IABS(JNT(K2-1) ) . EQ.O)  GO  TO  46  DAUX32 

IF  (FBEE(K2-1) )  GO  TO  46  SLIP 

IF  (ISING(K2) .NE.O)  GO  TO  46  DAUX32 

DAUX32 

-1  DAUX32 

C23 (K2- 1 ,N)  =  B22(K2-1 ,K2)PHI  (K2) A23(K2.H)  DAUX32 

DAUX32 

- 1  DAUX32 

C32 (H.K2-1)  =  B32 (N,K2) PHI  (K2) A22 (K2 ,K2- 1 )  DAUX32 

DAUX32 

KJHT  =  NQSJNT  +  K2  -  1  DAUX32 

IJ  =  IJ+l  DAUX32 

IJK(KJNT,NNS)  =  IJ  DAUX32 

IJK  (1THS,  KJHT)  =  IJ+1  DAUX32 

DO  45  1=1,3  DAUX32 

DO  45  J=1 ,3  DAUX32 

SUM  =  0.0  DAUX32 

TUM  =  0.0  DAUX32 

DO  44  K=1 ,3  DAUX32 

SUM  =  SUM  ♦  A22 (K, I , 2*K2-2)  »  RPHI(K,K2)  »  A23(K,J,2«H  )  DAUX32 

44  TUM  =  TUM  ♦  B32(I,K,2*N  )  «  BPHKK.K2)  »  A22 (K, J,2»K2-2)  DAUX32 

C(I.J.IJ  )  =  -SUM  DAUX32 

45  C(I,J,IJ+1)  =  -TUM  DAUX32 

IJ  =  IJ*1  DAUX32 

46  IF  (HJHT.LE.O)  GO  TO  60  DAUX32 

DO  56  L* 1 , HJMT  DAUX32 

IF  (FBEE(L) )  GO  TO  56  SLIP 

IF  (IABS(JHT(L) ) .HE.K1)  GO  TO  51  DAUX32 

IF  (ISING(Kl) .NE.O)  GO  TO  51  DAUX32 

DAUX32 

FOB  ANY  L  SUCH  THAT  JHT(L)  =  K1  DAUX32 

DAUX32 

-1  DAUX32 

C23(L,N)  =  B22 ( L , K 1 ) PHI  (XI) A23 (K1 ,N)  DAUX32 

DAUX32 

- 1  DAUX32 

C32 (N , L)  =  B32 (N , K1 ) PHI  (K1)A22(K1 ,L)  DAUX32 

DAUX32 

KJHT  =  NQSJNT  +  L  DAUX32 

IF  (IJK(KJHT.HHS) .HE.O)  GO  TO  48  DAUX32 

IJ  =  IJ*1  DAUX32 

I JK (KJHT , HNS)  =  IJ  DAUX32 
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IJK(NVS.KJNT)  =  IJ+1 
DO  47  J=1 ,3 
DO  47  1=1,3 
C(I,J.IJ  )  =  0.0 

47  Cd,J,IJ+l)  =  0.0 
IJ  =  IJ*1 

48  JJ  =  I JK (KJNT ,NNS) 

DO  50  1=1,3 

DO  50  J=1 ,3 
SOM  =  Cd.J.JJ) 

TOM  =  Cd.J,JJ+l) 

DO  49  K= 1 ,3 

SOM  =  SOM  ♦  A22(X,I,2*L-1  )  »  BFHI(X.Kl)  »  A23(X,J,2«H-1  ) 

49  TOM  =  TOM  +  B32(I ,K,2«V-1  )  •  RPHI(X.Xl)  «  A22(X, J,2*L-1  ) 
C(I,J.JJ)  =  SOM 

50  C(I,J,JJ*1)  =  TOM 

51  IF  ( IABS ( JNT (L) ) . NE. X2)  00  TO  56 
IF  (ISINQ(K2) .HE.O)  00  TO  56 

FOB  ANT  L  SOCH  THAT  JNT(L)  =  K2 


C23 (L ,N)  =  B22 (L,K2)PHI  (X2) A23 (X2 ,N) 


C32(N,L)  =  B32(N,K2)PHI  (X2) A22(X2,L) 

XJNT  =  MQSJNT  ♦  L 
IF  (IJX(XJNT.irNS)  .NE.O)  00  TO  53 
IJ  =  IJ+1 

IJX(XJNT.MNS)  =  IJ 
IJX(NNS.XJNT)  =  IJ+1 
DO  52  J=1 ,3 
DO  52  1=1,3 
C(I,J.IJ  )  =  0.0 

52  Cd.J.IJ+l)  =  0.0 
IJ  =  IJ*1 

53  JJ  =  IJX(XJMT,WIS) 

DO  55  1=1,3 

DO  55  J=1 ,3 
SOM  =  C(I,J,JJ) 

TOM  =  Cd,J,JJ+l) 

DO  54  X=1 ,3 

SOM  =  SOM  ♦  A22(K,1 ,2»L-1  )  •  HPHKX.X2)  «  A23(X,J,2»N  ) 

54  TOM  =  TOM  ♦  B32(I,X,2*N  )  *  BPHI(X,X2)  »  A22(X, J,2«L-1  ) 

C(I,J,JJ)  =  SOM 

55  Cd.J.JJd)  =  TOM 

56  CONTINUE 
60  CONTINUE 

CALL  ELTIMEI2 , 18) 


DA0X32 

DAUX32 

DAUX32 

DAOX32 

DAOX32 

DAUX32 

DAUX32 

DA0X32 

DA0X32 

DA0X32 

DAUX32 

DAUX32 

DAUX32 

DA0X32 

DAUX32 

DA0X32 

DAUX32 

DAOX32 

DAUX32 

DAUX32 

DAUX32 

DA0X32 

DAUX32 

DA0X32 

DAOX32 

DA0X32 

DA0X32 

DAUX32 

DAUX32 

DA0X32 

DAOX32 

DAUX32 

DAOX32 

DAOX32 

DAUX32 

DAOX32 

DAUX32 

DAUX32 

DAOX32 

DAUX32 

DAOX32 

DA0X32 

DAUX32 

DAUX32 

DA0X32 

DA0X32 

DA0X32 

DA0X32 

DAUX32 

DA0X32 
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SUBROUTINE  DAUX33 


CALLED  BY  SUBROUTINE  DAUX  TO  COMPUTE 


DAUX33 

REV  IV  07/24/86SLIP 

DAUX33 

DAUX33 


c 

-1 

-1 

DAUX33 

c 

(C33)  = 

(B31) (M) 

(AI3)  ♦ 

(B32) (PHI) 

(A23) 

-  (B35) 

DAUX33 

c 

DAUX33 

c 

-1 

-1 

DAUX33 

c 

(R3)  = 

(B31) (M) 

(Ul)  ♦ 

(B32) (PHI) 

(U2) 

-  (V3) 

DAUX33 

c 

IMPLICIT 

REAL* 8 

(A-H.O-Z) 

DAUX33 

DAUX33 

COMMON/ CONTRL/  T I ME , NSEG , HJNT , HPL , NBLT , NBAG , HVEH , NQRND ,  DAUX33 

•  NS , NQ , NSD , NFLX , NHRNSS , NWINDF , NJNTF , NPRT (36) , NPG  PAGE 

COMMON/SGMNTS/  D(3,3,30) ,WMEG(3.30) ,WMEGD(3,30) ,U1(3,30) ,U2(3,30) , DAUX33 
»  SEGLP(3,30) ,SEGLV(3,30) ,SEGLA(3,30) ,NSYM(30)  DAUX33 

COMMON/ DESCRP/  PHI (3,30) ,W(30) ,RW(30) ,SR(4,60) ,HA(3,80) ,HB(3,60) .  SLIP 
»  RPHI (3,30) ,HT(3,3,60) ,SPRING(5 ,90) , VISC(7,90) ,  DAUX33 

»  JNT(30) ,IPIN(30) ,ISING(30) ,IGL0B(30) ,J0INTF(30)  DAUX33 

COMMON/ CMATRX/  VI (3.30) ,V2(3,30) , V3 ( 3 , 12) ,BI2(3.3,60) ,A22(3,3,60) , DAUX33 
»  F (3 ,30)  ,TQ (3 ,30)  ,  WJ  (30)  , A1 1  (3 ,3 ,30)  SLIP 

COMMON/CSTRNT/  A13(3,3,24) ,A23(3,3,24) ,B31 (3,3,24) ,B32(3,3,24) ,  DAUX33 

»  HHT (3,3, 12) ,RK1 (3, 12) ,RK2(3,12) ,QQ(3,I2) ,TQQ(3,12) , DAUX33 


»  RQQ(3, 12) ,HQQ(3, 12) ,SQQ(12) ,CFQQ(12) ,  DAUX33 

»  XQ1(12) ,KQ2(12) ,KQTYPE(12)  DAUX33 

COMMON/ TEMP VS/  C(3,3,600) ,RHS(3,54) ,IJK(54,54) .IJ.NQ2S  CHGIII 

CALL  ELTIMEd  ,  Id)  DAUX33 

DO  90  N= 1 ,NQ  DAUX33 

IF  (KQTYPE(N) . LT.O)  GO  TO  90  DAUX33 

K1  =  KQ1(N)  DAUX33 

K2  =  KQ2 (N)  DAUX33 

NNS  =  NQ2S  -  NQ  ♦  N  DAUX33 

DAUX33 

-1  -1  DAUX33 

RHS(N)  =  B31(N,K1)M  (Kl)Ul(Kl)  +  B32(N,K1)PHI  (K1)U2(K1)  DAUX33 

- 1  - 1  DAUX33 

♦  B31 (N,K2) M  (K2)U1(K2)  ♦  B32(N,K2)PHI  (K2)U2(K2)  DAUX33 

DAUX33 

-  V3(N)  DAUX33 

DAUX33 

DO  63  1=1,3  DAUX33 

SUM  =  0.0  DAUX33 

DO  62  K=1 ,3  DAUX33 

SUM  =  SUM  ♦  B31 (I , X , 2»N- 1 ) »U1 (K ,X1 )  ♦  B32 (I ,K, 2*N- 1 ) *U2 (K,K1)  DAUX33 

*  +  B31 (I ,K,2»N  ) *U1 (K,K2)  ♦  B32(I,K,2»N  )»U2(K,K2)  DAUX33 

RHS(I.NNS)  =  SUM  -  V3(I,N)  DAUX33 

DAUX33 

-1  -1  DAUX33 

C33 (N.N)  =  B31(N,K1)M  (K1)A13(K1 ,N)  +  B32(N,K1)PHI  (Kl) A23(K1 ,N) DAUX33 

- 1  - 1  DAUX33 

♦  831 (N,K2)M  (K2) A13 (K2 ,N)  ♦  B32(N,K2)PHI  (K2)A23(K2,N)DAUX33 


-  V3(N) 

DO  63  1=1,3 
SUM  =  0.0 
DO  62  K=1 ,3 

82  SUM  =  SUM  ♦  B31 (I , X , 2»N- 1 ) »U1 (K ,X1 )  ♦  B32 (I ,K, 2*N- 1 ) *U2 (K,K1) 
*  +  B31 (I ,K,2»N  ) *U1 (K ,K2)  ♦  B32(I,K,2#N  )«U2(K,K2) 

63  RHS(I.NNS)  =  SUM  -  V3(I,N) 


WWW 


DAUX33 

-  B3S (N,M)  DAUX33 

DAUX33 

IJ  =  IJ+1  DA0X33 

IJK(NNS.NNS)  =  IJ  DAUX33 

IF  (KQTTPE(N) .EQ.2)  00  TO  51  DAUX33 

IF  (KQTTPE(N) .EQ.4)  GO  TO  51  DA0X33 

DO  65  1=1,3  DAUX33 

DO  65  J=1 ,3  DADX33 

SUM  =  -HHTd.J.H)  DAUX33 

IF  (I.EQ.J)  SUM  =  1.0+SUM  DAUX33 

DO  64  K= 1 , 3  DAUX33 

64  SUM  =  SUM  ♦  B31 (I ,K,2*N-1)«  BW(  Kl) *A13(K, J,2»N-1)  DAUX33 

*  +  B31 (I ,K,2«N  )«  BW(  K2) *A13 (K , J , 2*N  )  DAUX33 

»  ♦  B32 (I ,K , 2»M- 1) «BPHI (K ,K1) *A23 (K, J ,2*H-1)  DAUX33 

«  ♦  B32(I ,K.2*N  )*RPHI(K,K2)«A23(K,J,2«N  )  DAUX33 

65  C(I,J,IJ)  =  SUM  DAUX33 

GO  TO  59  DAUX33 

DAUX33 

FOB  KQTTPE  =  2  OB  4,  SET  C33Uf.lI)  =  B«I  DAUX33 

WHERE  B  =  SUM  OF  DIAGOMAL  ELEMENTS  OF  DAUX33 

-1  -I  DAUX33 

(B31) (M)  (A13)  +  (B32) (PHI)  (A23)  DAUX33 

DAUX33 

51  SUM  =  0.0  DAUX33 

DO  55  1=1.3  DAUX33 

DO  55  K=1 ,3  DAUX33 

55  SUM  =  SUM  +  B31 (I ,K,2*M-1) *  BW(  Kl) *A13 (K. I , 2*N- 1)  DAUX33 

*  +  B31 (I ,K,2*N  )»  BW(  K2) *A13 (K, I ,2»N  )  DAUX33 

*  +  B32 (I , K , 2»N- 1) »HPHI (K ,K1) »A23 (K. I , 2*H-1)  DAUX33 

»  ♦  B32 ( I ,K,2*N  ) *BPHI (K,K2) «A23 (K, I ,2«N  )  DAUX33 

DO  57  1=1.3  DAUX33 

DO  56  J=1 ,3  DAUX33 

56  C(I.J.IJ)  =  0.0  DAUX33 

57  C(I.I.IJ)  =  SUM  DAUX33 

59  IF  (N.EQ.NQ)  GO  TO  90  DAUX33 

N1  =  N+ 1  DAUX33 

DO  85  M=N1 ,NQ  DAUX33 

IF  (KQTTPE (M) . LT.O)  GO  TO  85  DAUX33 

MNS  =  NQ2S  -  NQ  +  M  DAUX33 

IF  (ISING(Kl) .NE.O)  GO  TO  75  DAUX33 

IF  (Kl.NE.KQl(M))  GO  TO  70  DAUX33 

IF  (IJK(MNS.NNS) .NE.O)  GO  TO  67  DAUX33 

DAUX33 

FOB  ANT  M>N  SUCH  THAT  Kl (N)  =  Kl (M)  DAUX33 

DAUX33 

- 1  DAUX33 

C33 (N.M)  =  C (N.M)  ♦  B3KN.K1)  M  (Kl )  A13 (Kl  ,M)  DAUX33 

-1  DAUX33 

♦  B32(N,K1)PBI  (Kl) A23(K1 ,M)  DAUX33 


m 


m 


DAUX33 

-1 

DADX33 

C33 (M,N)  =  C(M,B)  ♦  B3KM.K1)  M  (K1)A13(K1 ,N) 

DAUX33 

-1 

DADX33 

♦  B32 (U,K1) PHI  (K1)A23(K1 ,N) 

DAUX33 

DAUX33 

IJ  =  IJ+1 

DADX33 

IJK(MMS ,BBS)  =  IJ 

DADX33 

IJKdiNS.IOIS)  *  IJ+1 

DAUX33 

DO  66  J=l,3 

DADX33 

DO  66  1=1,3 

DADX33 

Cd.J.IJ  )  =  0.0 

DADX33 

66 

Cd.J.IJ+l)  =  0.0 

DADX33 

IJ  =  IJ+1 

DADX33 

67 

JJ  =  IJK(MNS.MHS) 

DADX33 

DO  69  1=1,3 

DADX33 

DO  69  J=1 ,3 

DAUX33 

SUM  =  C(I,J,JJ) 

DAUX33 

TDM  =  C(I,J,JJ+1) 

DADX33 

DO  68  K=1 ,3 

DAUX33 

SUM  =  SUM  +  B31(I.X,2*H-1}«  BW(  XI) «A13(X, J,2*M-1) 

DADX33 

»  +  B32 (I , K , 2»B- 1) *BPHI (K ,K1) *A23 (K , J , 2*M-1) 

DADX33 

68 

TUM  =  TDM  +  B31(I,K,2«M-1)«  RW(  K1)«A13(K,J,2*B-1) 

DADX33 

»  ♦  B32 (I ,K , 2*M- 1) »RPHI (K ,K1) *A23 (K , J , 2«H- 1) 

DAUX33 

C(I.J,JJ  )  =  SOM 

DAUX33 

69 

C(I,J,JJ+1)  =  TOM 

DADX33 

70 

IF  (Kl .NE.KQ2(M) )  GO  TO  75 

DAUX33 

IF  (IJK(MHS.HHS) .HE.O)  GO  TO  72 

DAUX33 

DADX33 

FOB  AMY  M>H  SDCH  THAT  K1(H)  =  K2(M) 

DADX33 

DAUX33 

-1 

DAUX33 

C33(N,M)  =  C(N,M)  +  B3MN.K1)  M  (Kl)  A13  (K2  ,M) 

DAUX33 

-1 

DADX33 

+  B32 (H.Kl ) PHI  (Kl ) A23 (K2 ,M) 

DAOX33 

DA0X33 

-1 

DAUX33 

C33  (M,M)  =  C(M,H)  +  B3KM.K2)  M  (Kl)  A13(K1  ,H) 

DAUX33 

-1 

DADX33 

+  B32 (M,K2) PHI  (Kl) A23(K1 ,H) 

DAUX33 

DAUX33 

IJ  =  IJ+1 

DADX33 

IJK(MNS,miS)  =  IJ 

DAUX33 

IJKdWS.MNS)  =  IJ+1 

DADX33 

DO  71  J=1 ,3 

DAUX33 

DO  71  1=1,3 

DADX33 

Cd.J.IJ  )  =  0.0 

DADX33 

71 

C(I,J,IJ+1)  =  0.0 

DADX33 

IJ  =  IJ+1 

DAUX33 

72 

JJ  =  IJK (MBS, BBS) 

DADX33 

DO  74  1=1,3 
DO  74  J=1 ,3 


SOM  =  C(I,J,JJ) 

TOM  =  Cd.J.JJ+1) 

DO  73  K=1 , 3 

SOM  =  SOM  ♦  B31 (I ,K,2*M- 1) *  BW(  Kl) »A13 (K, J , 2*M  ) 

«  ♦  B32 (I  ,K,2*M-1) *BPHI  (K,K1) *A23 (K, J, 2*M  ) 

73  TOM  =  TOM  ♦  B31(I,K,2»M  )•  BW(  Kl)  *A13(K, J,2*M-1) 

*  ♦  B32(I ,K,2*M  ) *BPHI (K ,K1) »A23 (K, J ,2»M-1) 

C(I,J,JJ  )  =  SOM 

74  C(I,J,JJ+1)  =  TOM 

75  IF  (ISING(K2) .HE.O)  GO  TO  85 

IF  (K2. VE.KQ1 (M) )  GO  TO  80 

IF  ( I JK (MIS, MVS) .HE.O)  GO  TO  77 


FOB  AMY  M>H  SOCH  THAT  K2(M)  =  K1(M) 


C33 (M,M)  =  C (N,M)  +  B3KV.K2)  M  (K2) A13 (Kl  ,M) 

-1 

+  B32 (M,K2) PHI  (K2) A23 (Kl ,M) 


C33 (M,N)  =  C (M, V)  ♦  B3KM.K1)  M  (K2)A13(K2,M) 

-1 

♦  B32(M,K1)FHI  (X2) A23(K2,M) 


IJ  =  IJ+1 
IJK(MNS.MMS)  =  IJ 
IJK(NMS.MNS)  =  IJ+1 
DO  76  J=1 ,3 
DO  76  1=1,3 
C(I.J,IJ  )  =  0.0 

76  C(I.J.IJ+1)  =  0.0 

IJ  =  IJ+1 

77  JJ  =  IJK(MHS,MNS) 

DO  79  1=1,3 

DO  79  J=1 ,3 
SOM  =  C(I,J,JJ) 

TOM  =  C(I,J,JJ+1) 

DO  78  K=1 ,3 

SOM  =  SOM  +  B31 (I ,K,2»M  )*  BW(  K2) «A13(K, J,2*M-1) 

»  +  B32 (I ,X, 2*V  ) *BPHI (X ,K2) »A23 (K, J , 2»M-1) 

78  TOM  =  TOM  +  B31 (I ,K,2»M-1) •  BW(  K2)«A13(K,J,2«M  ) 

«  +  B32d  , K,2«M-1)«BPHI  (K,K2)  *A23(K,J,2*M  ) 

C(I,J,JJ  )  =  SOM 

79  Cd,J,JJ+l)  =  TOM 

80  IF  (K2.ME.KQ2(M) )  GO  TO  85 

IF  dJX(MMS.VMS) .VE.O)  GO  TO  82 


DAOK33 

DA0X33 

DA0X33 

DAOX33 

DAOX33 

DAOX33 

DAOX33 

DAOX33 

DAOX33 

DAOX33 

DAOX33 

DAOX33 

DAUX33 

DAUX33 

DAOX33 

DAOX33 

DAOX33 

DAOX33 

DAOX33 

DAOX33 

DAOX33 

DAUX33 

DAOX33 

DAOX33 

DAOX33 

DAOX33 

DA0X33 

DAOX33 

DAOX33 

DAOX33 

DAOX33 

DAOX33 

DAOX33 

DAOX33 

DAOX33 

DAOX33 

DAOX33 

DAOX33 

DAOX33 

DAOX33 

DAOX33 

DA0X33 

DAOX33 

DAOX33 

DAOX33 

DA0X33 

DAOX33 

DAOX33 

DA0X33 

DA0X33 


c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 


FOB  ANY  M>M  SUCH  THAT  K2(M)  =  K2(M) 

-1 

C33 (N,M)  =  C(M.M)  ♦  B3KN.K2)  M  (K2)A13(K2,M) 

-1 

♦  B32 (N,K2) PHI  (K2)A23(X2.M) 

-1 

C33(M,M)  *  C  (M,N)  ♦  B31(M,X2)  M  (K2)A13(K2,H) 

-1 

♦  B32 (M,K2) PHI  (K2) A23(K2,H) 


IJ  =  IJ+1 
IJK(MMS ,MNS)  =  IJ 
IJK(NHS,MHS}  =  IJ+1 
DO  81  J*l,3 
DO  81  1*1,3 
C(I,J,IJ  )  =  0.0 

81  C(I,J,IJ+1)  *  0.0 
IJ  =  IJ+1 

82  JJ  =  IJK(MNS.NHS) 

DO  84  1=1,3 

DO  84  J=1 ,3 
SOM  =  C(I.J,JJ) 

TOM  =  C(I,J,JJ+1) 

DO  83  K=1 ,3 

SOM  =  SOM  +  B31 (I ,K,2*N 
»  ♦  B32(I ,K,2*M 

83  TOM  =  TOM  +  B31(I,K,2«M 

*  +  B32 (I ,K,2»M 

C(I,J,JJ  )  *  SOM 

84  Cd,J,JJ+l)  =  TOM 

85  CONTINOE 
90  CONTINOE 

CALL  ELTIME(2 , 19) 

RETURN 

END 


)«  BW(  X2)»A13(X,J,2*M 
) +RPHI (K,K2) *A23 (K , J , 2*M 
)«  BW(  K2) *A13 (K, J , 2*N 
) »BPHI (X ,K2) *A23 (K , J , 2»N 


) 

) 

) 

) 


DA0X33 

DA0X33 

DA0X33 

DA0X33 

DA0X33 

DA0X33 

DAUX33 

DADX33 

DA0X33 

DA0X33 

DAUX33 

DA0X33 

DAOX33 

DAOX33 

DA0X33 

DA0X33 

DA0X33 

DA0X33 

DA0X33 

DA0X33 

DAOX33 

DAUX33 

DA0X33 

DA0X33 

DAOX33 

DADX33 

DA0X33 

DAOX33 

DAOX33 

DA0X33 

DAOX33 

DAOX33 

DA0X33 

DAOX33 

DA0X33 

DA0X33 

DA0X33 
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M 


SUBBOUT I HE  DAUX44  DAUX44 

BEV  I?  07/24/86SLIP 

IMPLICIT  BEAL*8(A-H,0-Z)  DAUX44 

COMMON/ CONTBL/  TIME , NSEQ , HJHT , HPL , HBLT , NBAS , HVEH , NGBND ,  DAUX44 

«  NS , HQ , NSD , NFLX , NHBHSS .HWINDF, NJHTF , NPBT <  36 ) . HPG  PAGE 

COMMON/ SGMNTS/  D(3,3,30) ,WMEG(3,30) ,WMEGD(3,30) ,U1(3,30) ,U2(3,30) , DAUX44 
*  SEGLP(3,30) ,SEGLV(3,30) ,SEGLA(3,30) ,NSTM(30)  DAUX44 

COMMON/DESCBP/  PHI(3,30) ,W(30) ,BW(30) ,SB(4,60) ,HA(3,60) ,HB(3,60) ,  SLIP 
»  BPHI (3,30) ,HT(3 ,3 ,60) .SPRING (5 ,90) , VISC (7 ,90) ,  DAUX44 

»  JNT(30) ,IPIN(30) ,ISING(30) ,IGL0B(30) ,J0INTF(30)  DAUX44 

COMMON/CMATBX/  VI (3,30) ,V2(3,30) ,?3(3,I2) ,B12(3,3,60) ,A22(3, 3, 60) , DAUX44 
»  F(3,30) ,TQ(3,30) ,WJ(30) ,A11(3,3,30)  SLIP 

COMMON/CSTBNT/  A13(3,3,24) ,A23(3,3,24) ,B31(3,3,24) ,B32(3,3,24) ,  DAUX44 
»  HHT(3,3, 12) ,8X1(3,12) ,8X2(3,12) ,QQ(3,12) ,TQQ(3,12) .DAUX44 


»  BQQ (3 , 12) ,HQQ(3 , 12) ,SQQ(12) ,CFQQ(12) , 

*  KQ1 (12) , KQ2 (12) ,KQTYPE(12) 

COMMON/FLXBLE/  HF C 4 , 12,8) ,B42(3,3,24) ,V4(3,8) ,NFLEX(3,8) 

LOGICAL* 1  FBEE 

CuMMON/TEMPVS/  C(3,3,600) ,BHS(3,54) ,IJX(54,54) ,IJ,NQ2S 

*  ,IDUM(458) .FREE (30) 

IF  (NFLX.EQ.O)  GO  TO  99 

CALL  ELTIMEd  ,33) 

DO  90  L=1 , NFLX 
N1  =  NFLEX(l.L) 

N2  =  NFLEX(2,L) 

N3  =  NFLEX(3,L) 

IJ  =  IJ+1 
DO  10  1=1,3 
DO  10  J=1 ,3 
C(IfJ,IJ)  =  0.0 
DO  10  X=1 ,3 

10  C(I,J,IJ)  =  C(I,J,IJ)  ♦  B42 (I ,K,3*L-2) *BPHI (X ,N1) *B42 (J,X,3*L-2) 
»  ♦  B42(I,X,3»L-1)»BPHI(X,N2)*B42(J,X,3«L-1) 

»  +  B42 ( I ,K,3*L  ) «BPHI (X ,N3) *B42 ( J ,K , 3*L  ) 


NSL  =  2*NS+L 
IJX(NSL.NSL)  =  IJ 
DO  20  1=1,3 
BHSd.NSL)  =  -V4  (I  ,L) 

DO  20  J=1 , 3 

20  BHSd.NSL)  =  BHSd.NSL)  +  B42(I  ,J,3*L-2)  *U2(I  ,N1) 


♦  B42 (I , J,3*L- 1) *U2 (I ,N2) 

♦  B42 (I , J ,3*L  ) *U2 ( I ,N3) 


IF  (L.EQ.NFLX)  GO  TO  30 

LP1  =  L+I 

DO  29  M=LP1 , NFLX 

DO  28  11=1,3,2 

IL  =  NFLEX(II , L) 

IF  (ISING(IL) .NE.O)  GO  TO  28 
DO  27  JJ=1 ,3,2 

IF  (NFLEXdl  ,L)  . NE.NFLEX(JJ.M) )  GO  TO  27 


DAUX44 

DAUX44 

DAUX44 

SLIP 

CHGIII 

SLIP 

DAUX44 

DAUX44 

DAUX44 

DAUX44 

DAUX44 

DAUX44 

DAUX44 

DAUX44 

DAUX44 

DAUX44 

DAUX44 

DAUX44 

DAUX44 

DAUX44 

DAUX44 

DAUX44 

DAUX44 

DAUX44 

DAUX44 

DAUX44 

DAUX44 

DAUX44 

DAUX44 

DAUX44 

DAUX44 

DAUX44 

DAUX44 

DAUX44 

DAUX44 

DAUX44 


m 


NSM  =  2*NS+M  DAUX44 

JK  =  IJK(NSL , NSM)  DAUX44 

KJ  =  I JK(MSM.MSL)  DAUX44 

IF  (JK.QT.O)  GO  TO  22  DAUX44 

IJK(HSL.HSM)  =  IJ+1  DAUX44 

I JK (NSM.NSL)  =  IJ+2  DAOX44 

JK  =  IJ+1  DAUX44 

KJ  =  IJ+2  DADX44 

IJ  =  IJ+2  DAUX44 

DO  21  1=1,3  DAUX44 

DO  21  J=l,3  DAUX44 

21  C(I , J , JK)  =  0.0  DAUX44 

22  LI  =  3+L+II-3  DAUX44 

MJ  =  3»M+JJ-3  DA0X44 

DO  24  1=1,3  DAUX44 

DO  24  J=1 ,3  DAUX44 

DO  23  K=1 ,3  DAUX44 

23  C(I,J,JK)  =  C(I.J.JK)  +  B42 (I ,K,LI) *HPHI (K, IL) *B42 (J,X,MJ)  DAUX44 

24  C(J.I.KJ)  =  C(I,J.JK)  DAUX44 

27  COHTIMUE  DAUX44 

28  CONTINUE  DAUX44 

29  CONTINUE  DAUX44 

30  IF  (NQ.EQ.O)  GO  TO  40  DAUX44 

DO  39  M= 1 , NQ  DAUX44 

IF  (KQTYPE(M) . LT.O)  GO  TO  39  DAUX44 

DO  38  11=1,3  DAUX44 

LM  =  0  DAUX44 

IF  (NFLEX(II.L) .EQ.KQl(M))  LM  *  2«M-1  DAUX44 

IF  (NFLEX(II ,L) .EQ.KQ2(M) )  LM  *  2»M  DAUX44 

IF  (LM.EQ.O)  GO  TO  38  DAUX44 

IL  =  NFLEXdl , L)  DAUX44 

IF  (ISING(IL) .NE.O)  GO  TO  38  DAUX44 

NSM  =  2»NS+NFLX+M  DAUX44 

JK  =  IJK(NSL.NSM)  DAUX44 

KJ  =  I JK (NSM.NSL)  DAUX44 

IF  (JK.QT.O)  GO  TO  32  DAUX44 

IJK(NSL.NSM)  =  IJ+1  DAUX44 

IJK (NSM.NSL)  =  IJ+2  DAUX44 

JK  =  IJ+1  DAUX44 

KJ  =  IJ+2  DAUX44 

IJ  =  IJ+2  DAUX44 

DO  31  1=1,3  DAUX44 

DO  31  J=1 ,3  DAUX44 

C(I,J,JK)  =  0.0  DAUX44 

31  C(I,J,KJ)  =  0.0  DAUX44 

32  LI  =  3+L+II-3  DAUX44 

DO  33  1=1,3  DAUX44 

DO  33  J=1 ,3  DAUX44 

DO  33  K=1 ,3  DAUX44 

Cd.J.JK)  =  Cd.J.JK)  +  B42  (I  ,K  ,LI)  •BPHI  (K,  IL)  *A23(K,  J  ,LM)  DAUX44 


33  C(I.J,KJ)  -  C(I,J,KJ)  +  B32 (I ,K,LM) *RPHI (K , IL) *B42 ( J ,K,LI)  DAUX44 

38  CONTINUE  DAUX44 

39  COirriMUE  DAUX44 

40  IF  (NJNT.EQ.O)  GO  TO  90  DAUX44 

DO  59  M= 1 , NJNT  DAOX44 

IF  (JHT(M)  .E0.0)  00  TO  59  DAUX44 

DO  58  11-1,3  DAUX44 

Lli  =  0  DAUX44 

IF  (NFLEX(II , L)  .  EQ.  IABS(JHT(M) ) )  LM  =  2*11-1  DAUX44 

IF  (HFLEX(II.L) .EQ.M+1)  LM  -  2*M  DA0X44 

IF  (LM.EQ.O)  00  TO  58  DAUX44 

IL  =  NFLEXdl  ,L)  DAUX44 

IF  (ISING(IL) .ME.O)  GO  TO  58  DAUX44 

NSM  *  2*NS+NFLX+NQ+M  DAUX44 

JK  =  IJK(HSL.NSM)  DAUX44 

KJ  =  IJK (NSM.NSL)  DA0X44 

IF  (JK.OT.O)  GO  TO  42  DAUX44 

IJK(NSL.NSM)  *  IJ+1  DAUX44 

I JK (NSM.NSL)  =  IJ+2  DAUX44 

JK  =  IJ+1  DAUX44 

KJ  =  IJ+2  DAUX44 

IJ  =  IJ+2  DAUX44 

DO  41  1=1,3  DAUX44 

DO  41  J=1 ,3  DAOX44 

41  C(I.J,JK)  =0.0  DAUX44 

42  LI  =  3*L+II-3  DADX44 

DO  44  1=1,3  DA0X44 

DO  44  J=1 ,3  DAUX44 

DO  43  K=1 ,3  DA0X44 

43  C(I,J,JK)  =  Cd.J.JK)  ♦  B42  (I ,  K  ,LI)  *BPHI  (K,  IL)  *B12  (J,K,LM)  DA0X44 

44  C(J.I.KJ)  =  C(I,J,JK)  DAUX44 

IF  (FREE(M) )  GO  TO  58  SLIP 

NSM  =  2*NS+NFLX+NQ+NJNT+M  DA0X44 

JK  =  IJK(NSL.NSM)  DAUX44 

KJ  =  IJK (NSM.NSL)  DAUX44 

IF  (JK.GT.O)  GO  TO  52  DAUX44 

IJK(NSL.NSM)  =  IJ+1  DAUX44 

IJK (NSM.NSL)  =  IJ+2  DAUX44 

JK  =  IJ+1  DAUX44 

KJ  =  IJ+2  DAUX44 

IJ  »  IJ+2  DAUX44 

DO  51  1=1,3  DA0X44 

DO  51  J=1 ,3  DAUX44 

51  C(I,J,JK)  =  0.0  DAUX44 

52  SET  =  1.0  DAUX44 

IF  (IL.EQ.M+1)  SET  =  -1.0  DAUX44 

DO  54  1=1,3  DAUX44 

DO  54  J=1 ,3  DAOX44 

DO  53  K=1 ,3  DAUX44 

53  C(I,J,JX)  =  C(I,J,JK)  +  SET*B42 (I . K ,LI) *BPHI (K, IL) *A22 (K, J ,LM)  DAUX44 


54 

C ( J , I ,KJ)  *  C(I.J,JK) 

DAUX44 

58 

COVTINUE 

DAUX44 

59 

CONTINUE 

DAUX44 

90 

CONTI HUE 

DAUX44 

CALL  ELTIME(2,33) 

DAUX44 

99 

RETURN 

DAUX44 

END 

DAUX44 

SOBBOOTIME  DAOX55  DAOX55 

REV  I?  07/24/86SLIP 

IMPLICIT  REAL* 8 ( A-H , O-Z)  DAOX55 

COMMOM/COMTRL/  TIME , HSEG , HJMT , HPL , MBLT , HBAQ , HVEH , HGRND ,  DAOX55 

«  MS , MQ , NSD , MFLX , MHBMSS , MWI HDF , H JMTF , HPBT ( 36 ) , MPQ  PAGE 

COMMOM/SGMMTS /  0(3,3,30) ,MMEG(3I30) ,HMEGI>(3,30) ,01(3,30) ,02(3,30) ,DA0X55 

*  SEGLP(3,30) ,SEGLV(3,30) ,SEGLA(3,30) ,HSTM(30)  DA0X55 

COMMON/DESCBP/  PHI (3,30) ,W(30) ,BW(30) ,SB(4,60) ,HA(3,60) ,HB(3,60) ,  SLIP 

»  BPHI(3,30) ,HT(3,3,60) ,SPBIMG(5 ,90) ,VISC(7,90) ,  DAOX55 

*  JNT(30) , IPIH(30) , ISIMG(30) ,IGL0B(30) ,J0IMTF(30)  DAOX55 
COMMOH/CMATBX/  VI (3,30) ,V2(3,30) ,73(3,12) ,B12(3,3,60) ,A22(3,3,60) .DAOX55 

«  F(3,30) ,TQ(3,30) ,WJ(30) ,A11(3,3,30)  SLIP 

COMMON/CSTBMT/  A13(3,3,24) ,A23(3,3,24) ,B31 (3,3,24) ,B32(3,3,24) ,  DAOX55 

*  HHT (3 , 3 , 12) , RK1 (3 , 12) ,BK2(3,12) ,QQ(3,12) ,TQQ(3,12) .DAOX55 

*  BQQ(3, 12) ,HQQ(3, 12) , SQQ(12) ,CFQQ(12) ,  DAUX55 

»  KQ1(12) ,KQ2(12) ,KQT7PE(12)  DAOX55 

COMMOM/FLXBLE/  HF(4, 12,8) ,B42(3,3,24) ,74(3,8) ,MFLEX(3,8)  DAOX55 

COMMOM/CNSNTS/  PI .RADIAN, G, THIRD , EPS (24) ,  DAOX55 

*  UNITL,0NITM,UHITT,GRAVTY(3) ,TWOPI  TMOPI 

LOGICAL* 1  FREE  SLIP 

COMMON /TEMP VS/  C(3,3,600) ,BHS(3,54) ,IJK(54,54) .IJ.MQ2S  CHGIII 

»  , ID0MC458) .FREE (30)  SLIP 

CALL  ELTIME(1 ,30)  DAOX55 

IS  =  0  DAOX55 

DO  99  1=1, NGBMD  DA0X55 

IF  (ISIMG(I) .LE.O)  GO  TO  99  DA0X55 

IS  =  IS+1  DA0X55 

IJ  =  IJ+1  DAOX55 

IJK (IS  ,IS  )  =  IJ  DAOX55 

I JK( IS+1, IS+1)  =  IJ+1  DA0X55 

DO  11  J=1 ,3  DAOX55 

RHS (J , IS  )  =  01 (J , I)  +  W(I)*GBAVTY(J)/G  DAOX55 

RHS ( J , IS+1)  =  02(J,I)  DAOX55 

01 (J, I)  =  0.0  DA0X55 

02 ( J , I )  =  0.0  DA0X55 

DO  10  K= 1 , 3  DAOX55 

C (J ,K , IJ  )  =  0.0  DA0X55 

10  C (J ,K, IJ+1)  =  0.0  DAOX55 

C(J,J,IJ  )  =  W(I)/G  DA0X55 

11  C(J,J,IJ+1)  =  PHI (J, I)  DAOX55 

IJ  =  IJ+1  DAOX55 

IF  (NFLX.EQ.O)  GO  TO  19  DA0X55 

DO  15  N= 1 , MFLX  DA0X55 

LM  =  0  DA0X55 

IF  (MFLEX(1 ,N) .EQ.I)  LM  =  3*N-2  DA0X55 

IF  (NFLEX(2,N) .EQ.I)  LM  =  3»N-1  DAOX55 

IF  (MFLEX(3,N) .EQ.I)  LM  =  3«M  DAOX55 

IF  (LM.EQ.O)  GO  TO  15  DAOX55 

DO  14  J= 1 , 3  DAOX55 

DO  14  K= 1 ,3  DA0X55 


<V  J.K.IJ+l)  =  B42(K, J,LN) 

DAUX55 

14  C(J.K,IJ*2)  »  B42(J,K,LH) 

SLIP 

NNS  =  2+NS+N 

DAUX55 

I JK ( IS+ 1 ,NNS)  =  IJ+1 

DAUX55 

IJK(NNS,IS+1)  =  IJ+2 

DAUX55 

IJ  =  IJ+2 

DAUX55 

15  CONTI HUE 

DAUX55 

19  IF  (NQ.EQ.O)  GO  TO  30 

DAUX55 

DO  25  N=1 ,NQ 

DAUX55 

IF  (KQTYPE(N) .LT.O)  GO  TO  25 

DAUX55 

LN  s  0 

DAUX55 

IF  (I .EQ.KQ1 (M) )  LN  =  2*N-1 

DAUX55 

IF  (I . EQ.KQ2 (N) )  LN  *  2»N 

DAUX55 

IF  (LN.EQ.O)  GO  TO  25 

DAUX55 

DO  20  J=1 ,3 

DAUX55 

DO  20  K*1 ,3 

DAUX55 

C(J,K,IJ+1)  =  A13 ( J ,K,LN) 

DAUX55 

C ( J , K , I J+2)  =  A23(J,K,LN) 

DAUX55 

C(J,K,IJ+3)  =  B31(J,K,LN) 

SLIP 

20  C (J ,K, IJ+4)  =  B32(J,K,LN) 

SLIP 

NNS  =  2*NS+NFLX+N 

DAUX55 

IJK(IS  , NNS)  »  IJ+1 

DAUX55 

I JK (IS+ 1 , NNS)  =  IJ+2 

DAUX55 

I JK (NNS, IS  )  =  IJ+3 

DAUX55 

IJK(NNS , IS+1)  =  IJ+4 

DAUX55 

IJ  *  IJ+4 

DAUX55 

25  CONTINUE 

DAUX55 

30  IF  (NJNT.EQ.O)  GO  TO  98 

DAUX55 

DO  65  N= 1 , NJNT 

DAUX55 

IF  (JNT(N) . EQ.O)  GO  TO  65 

DAUX55 

LN  s  0 

DAUX55 

IF  (I .EQ. IABS(JNT(N) ) )  LN  »  2«H-1 

DAUX55 

IF  (I.EQ.N+1)  LN  >  2»N 

DAUX55 

IF  (LN.EQ.O)  GO  TO  65 

DAUX55 

SET  =  1.0 

DAUX55 

IF  (I.EQ.N+1)  SET  =  -1.0 

DAUX55 

DO  40  J*1 ,3 

DAUX55 

DO  40  K»l,3 

SLIP 

C(J,K.IJ+1)  =  SET*A11(J,K,N) 

SLIP 

C(JfK, IJ+3)  =  SET+A11 (K, J,H) 

SLIP 

C(J,K,IJ+2)  =  B12 (K . J,LN) 

DAUX55 

40  C (J , J , IJ+4)  »  B12(J,K,LN) 

SLIP 

NNS  =  NQ2S  +  N 

DAUX55 

IJK(IS  , NNS)  =  IJ+1 

DAUX55 

IJKdS+l.NNS)  =  IJ+2 

DAUX55 

IJK(NNS,IS  )  =  IJ+3 

DAUX55 

I JK (NNS , IS+1)  =  IJ+4 

DAUX55 

IJ  =  IJ+4 

DAUX55 

IF  (FBEE(H) )  GO  TO  65 

SLIP 

DO  60  Jsl ,3 

DAUX55 

I 


DO  60  K=1 ,3 

DA0X55 

C(J,K,IJ+1)  *  SET*A22(J ,X,LN) 

DAUX55 

60 

C(J,K,IJ+2)  =  SET*A22(K, J,LH) 

SLIP 

MIS  =  MQ2S  ♦  MJMT  ♦  N 

DAUX55 

IJK(IS+1 ,  HNS)  =  IJ+1 

DADE 5 5 

IJK(M1S,IS+1)  *  IJ+2 

DADXS5 

IJ  =  IJ+2 

DAUX55 

65 

CONTINUE 

DADE55 

98 

IS  =  IS+1 

DAUX55 

99 

COHTIIUE 

DAUX55 

CALL  ELTIME(2,30) 

DAUX55 

RETURN 

DAUX55 

END 

DAUX55 

X£V 

My 

vyv  > 


SUBROUTINE  DHHP I N ( DD , BN , L , M , N ) 


C 

C 

C 

C 


SETS  DD  =  D(L)  IF  JOINT  II  IS  NOT  PINNED 
OR  DD  =  (I-HH. ) (D(L) )  IF  PINNED 


DHHP IN 

REV  IV  07/24/86SLIP 

DHHP IN 
DHHPIN 
DHHP IN 

IMPLICIT  REAL*8  (A-H.O-Z)  DHHPIN 

COMMON/ SGMNTS/  D(3,3,30) ,WMEG(3,30) ,WMEGD(3,30) ,U1(3,30) ,U2(3,30) .DHHPIN 
«  SEGLP (3 ,30) , SEQLV (3 ,30) ,SEGLA(3 ,30) ,NSTM(30)  DHHPIN 

COMMON/DESCRP/  PHI (3,30) ,W(30) ,RW(30) ,SR(4,60) ,HA(3,60) ,HB(3,60) ,  SLIP 
«  RPHI (3,30) ,HT(3,3,60) ,SPRING(5 ,90) , VISC(7,80) ,  DHHPIN 

«  JNT (30) , I PIN (30) , I SING (30) , IGLOB (30) , JOINTF (30)  DHHPIN 

COMMON/CEULER/  IEULEB(30) ,HIR(3,3,00) ,ANQ(3,30) ,ANGD(3,30) ,  JDRIFT 

*  FE(3,30) ,TQE(3,30) .CONST (5, 30)  JDRIFT 

DIMENSION  DD(3, 3) ,BN(3)  DHHPIN 

DO  10  J=1 ,3  DHHPIN 

BN ( J)  =  0.0  DHHPIN 

DO  10  1=1,3  DHHPIN 

10  DD(I,J)  =  D(I,J,L)  DHHPIN 

LGO  =  IPIN (M) +8  SLIP 

TSIGN  =  -1.0  DHHPIN 

GOTO  (90,90,90,20,90.90,90.90.30.90,00,00,00.30,30) , LGO  SLIP 

20  IF  (IEULER(M) .GE.7)  GO  TO  90  DHHPIN 

IF  (IEULER(M) . GE. 4)  GO  TO  30  DHHPIN 

TSIGN  =1.0  DHHPIN 

DO  21  J=1 ,3  DHHPIN 

DO  21  1=1,3  DHHPIN 

21  DD(I , J)  =  0.0  DHHPIN 

30  DO  31  J= 1 , 3  DHHPIN 

BN ( J)  =  HB(1,N)*D(1,J,L)  ♦  HB (2 ,N) »D(2 , J ,L)  ♦  HB (3 , N) «D (3 , J , L)  DHHPIN 
DO  31  1=1,3  DHHPIN 

31  DD (I , J)  =  DD(I , J)  ♦  TSIGN*BN(J) *HB(I ,N)  DHHPIN 

90  RETURN  DHHPIN 

END  DHHPIN 


SUBROUTINE  DINT 


C 

c 

c 

c 

c 

c 


c 

c 

c 


c 

c 

c 


c 

c 

c 


REV  IV 

IMPLICIT  REAL *8  (A-H.O-Z) 

COMMON/CONTRL/  TIME , NSEQ , NJNT , NPL , NBLT , NBAS , NVEH , NQRND , 

»  NS , NQ , NSD , NFLX , NHRNSS , NWI NDF , N JNTF , NPRT ( 36 ) ,NPQ 

COMMON/ INTEST/  SGTEST(3,4,30) ,XTEST(360  ) ,SEGT( 120) ,REGT(120) 
NOTE:  XTEST  SINGLY  DIMENSIONED  HERE. 

REAL  SEGT 

COMMON/CNSNTS/  PI .RADIAN, G.THIBD.EPS (24) . 

*  UNITL,UNITM,UNITT,GRAVTY(3) .TWOPI 
COMMON/CDINT/  UU(4) ,GH(3 .4) , 

*  E (3 , 240) ,  F(5,240) ,GG(5,240) ,Y(5,240) ,U(5,240) , 

*  H . HPRINT, HS . TPRINT .TSTART . ICNT . IDBL . I FLAG 
COMMON/COMAIN/  VAR(240) ,DER(240) , DT , HO , HMAX , HMIN , RSTIME , 

»  I STEP , NSTEPS . ND I NT , NEQ , I RS I N , I RSOUT 

LOGICAL  LNRT 
CALL  ELTIME (1,3) 

IF  (ISTEP.NE.O)  GO  TO  11 


DINT 

07/23/86TW0PI 

DINT 


DINT 

PAGE 

DINT 

DINT 

DINT 

DINT 

TWOPI 

DINT 

DINT 

DINT 

DINT 

DINT 

TGM0D1 

DINT 

DINT 


IN=0 : 
NOTE: 


DINT 

INITIAL  CALL  TO  INTEGRATOR  -  INITIALIZE  AND  RESET  PARAMETERSDINT 
FOR  EARLIER  VERSIONS  OF  CVS,  THE  VARIABLE  ’IN’(ISTEP  IN  THE  DINT 
CALLING  PROGRAM)  RAN  FRON  1  TO  NSTEPS'*- 1 ,  NOW  IT  RUNS  FROM  DINT 


0  TO  NSTEPS. 


TPRINT  = 
IDBL  =  2 
K  =  0 
GO  TO  13 


TIME 


IN*0:  ADVANCE  TPRINT  -  TIME  TO  RETURN  TO  CALLING  PROGRAM. 


11 


TPRINT  =  TPRINT  +  DT 
H  =  HPRINT 


ENTRY  TO  ADVANCE  INTEGRATOR 


12 


K  =  1 

CALL  UPDATE (K) 


NEGATIVE  K  FROM  UPDATE  IS  INDICATOR  TO  RESET  INTEGRABOR. 


DINT 

DINT 

DINT 

DINT 

DINT 

DINT 

DINT 

DINT 

DINT 

DINT 

DINT 

DINT 

DINT 

DINT 

DINT 

DINT 

DINT 

DINT 

DINT 


IF  (K.EQ.l)  GO  TO  15 

DINT 

c 

DINT 

• 

c 

RESET  OR  INITIALIZE  INTEGRATOR. 

DINT 

c 

DINT 

u 

13 

H  =  HO 

DINT 

HPRINT  =  HO 

DINT 

HS  =  0.0 

DINT 

i.V. 

ICNT  =  -2 

DINT 

• 

r  v 

• 

IF  (ISTEP.EQ.O  .OR.  NPRT (26) . EQ. 2)  CALL  OUTPUT (0) 

134 

DINT 

TX  =  VAR(II) »«2  ♦  VAB(II+1)««2  ♦  VAB(II*2)*«2  DINT 

TE  =  0.0  DINT 

TY  =  0.0  DINT 

12  =  II+2  DINT 

DO  45  1=11,12  DINT 

Z  =  GG(5 , I) * (VAB(I) -QG( 1 , I) )  ♦  GG(2,I)  ♦  H« (GG(3 , I) +H*GG(4 , I) )  DINT 
TE  =  TE  +  (DEB(I) -Z) **2  DINT 

TYD  =  TT  +  TX«GG(5,I)**2  DINT 

IF  (TYD. EQ. 0.0)  TYD  =  1.0  DINT 

45  TY  =  TY  +  (DEB(I) -Z) **2/TYD  DINT 

TM  =  1000.0»TIME  DINT 

IF  (NPBT(25) . NE.O)  WRITE  (6,46)  TM.SEGT(JJ) ,REGT(JJ) .TT.TE.TY,  DINT 

«  (XTEST(I) ,1=11,12)  DINT 

46  FORMAT  ('0  DINT  CONV.  TEST’ ,F10 . 3 , 2X.A4 ,2X, A8 ,6G12 . 4)  DINT 

IF  (TT.LT.XTEST(II))  GO  TO  47  DINT 

IF  (XTEST(II+1) .GT.0.0  .AND.  TE.LT.XTEST(II+1) )  GO  TO  47  DINT 

IF  (TY.GT.XTEST(II+2) )  GO  TO  48  DINT 

47  CONTINUE  DINT 

FAIL  =0.0  DINT 

48  CALL  ADJUST  (4,D1)  DINT 

IF  (FAIL. EQ. 0.0)  GO  TO  60  DINT 

IF  (L.EQ.NDINT)  GO  TO  49  DINT 

CALL  CMPUTE  (K.1.D1)  DINT 

IF  (K.LT.O)  GO  TO  50  DINT 

CALL  ADJUST  (5.DI)  DINT 

49  CONTINUE  DINT 

IF  (NPBT(25) .EQ.O)  WBITE  (6,46)  TM.SEGT(JJ) .BEGT(JJ) .TT.TE.TY,  DINT 

*  (XTEST(I) ,1=11,12)  DINT 

50  WBITE  (6,51)  TIME.H  DINT 

51  FOBMAT ( ’ 0  TEST  FAILED  AT  TIME  =  \F10.6,’  FOB  H  =  ’ .F10.6)  DINT 

ICNT  =  0  DINT 

IDBL  =  IDBL+2  DINT 

IF  (IDBL.GT.6)  IDBL  =  8  DINT 

IF  (K.GE.O)  GO  TO  58  DINT 

IF  (H.GT.HMIN+EPS(6) )  GO  TO  59  DINT 

WRITE  (6,52)  DINT 

52  FORMAT ( ’ 0  PBOGBAM  TERMINATED.  PDAUX  NEG  SQBT.  H  <  HMIN+EPS8. V  DINT 

«  '  RERUN  PROGRAM  WITH  SMALLER  HMIN  ON  INPUT  CARD  A. 4')  DINT 

STOP  31  DINT 

58  IF  (H. LE. HMIN+EPS (8) )  GO  TO  61  DINT 

IF  (NPRT(26) .EQ.2)  CALL  OUTPUT (1)  DINT 

59  TIME  =  TSTART  DINT 

H  =  0 . 5*H  DINT 

HPRINT  =  0. 5»HPRINT  DINT 

K  =  2  DINT 

GO  TO  16  DINT 

60  IF  (H.GT . 0 . 74*HPRINT)  ICNT  =  ICNT+1  DINT 

61  K  =  4  DINT 

M  =  0  DINT 

IF  (H.GT. HMIN  .AND.  IDBL.GT. 2)  IDBL  =  IDBL-1  DINT 


a 


3 


I 


GG4  =  2 . 0»H 

GG5  =  DEXP(-1600.0*H) 

DO  63  1  =  1 ,  MEQ 

F(3 , 1)  *  GG(3, 1)  ♦  GG4*GG(4 , 1) 

F (4 , 1 )  *  GG(4 , 1) 

F (5 . 1)  =  GG(5 , 1) 

Y(3 , I)  =  1(1,1) 

Y(4 , I)  =  Y(2 , I ) 

Y ( 5 , 1 )  =  GG5*U(3,I) 

0(5,1)  =  GG5»0(4 , I) 

CALL  QSET (F , Y , VAR , DEB , NQOAT) 

CALL  FDAUX  (VAB.DEB.M.K) 

DO  64  1=1 ,NEQ 

F ( 1 , 1)  *  VAB(I) 

F (2 . 1)  =  DEB ( I ) 

HS  =  H 

IF  (ICNT.LT. IDBL)  GO  TO  65 
ICHT  =  0 

H  =  DMIN1 (2.0*H,HMAX) 

HP R I NT  =  DMIN1(2.0*HPBINT,HMAX) 

CALL  UPDATE (2) 

XPRINT  =  TPRINT  -  TIME 

IF (XPRINT.GE.EPS (8) . AND . NPBT ( 26 ) .ME. 3. AND.NPRT(26) .01.0) 
»  CALL  OOTPOT ( 1 ) 

IF (XPBINT. GE. EPS (8) )  GO  TO  12 
LNBT  =  .FALSE. 

IF(NPRT(26) . GE.O)  LNBT  =  .TRUE. 

IF(NPRT(26) .LT.O)  INBT  =  IABS (NPRT(26) ) 

IF(NPRT(26) .LT.O)  LNRT  =  (MOD (ISTEP , IMBT) .EQ. 0) 

IF (LNBT)  CALL  OOTPOT (1) 

CALL  ELTIME(2,3) 

RETURN 

END 


DINT 

DINT 

DINT 

DINT 

DINT 

DINT 

DINT 

DINT 

DINT 

DINT 

DINT 

DINT 

DINT 

DINT 

DINT 

DINT 

DINT 

DINT 

DINT 

DINT 

DINT 

TOMOD1 

TOMOD1 

TGM0D1 

TGM0D1 

TGM0D1 

TGM0D1 

TGM0D1 

TGM0D1 

TGM0D1 

DINT 

DINT 

DINT 


SUBROUTINE  DOTT31  (A,B,C)  D0TT31 

C  REV  17  12/20/76D0TT3I 

C  PERFORMS  MATRIX  MULTIPLICATION  C  -  AB'  DOTT31 

C  WHERE  C  IS  A  3X3  MATRIX.  AND  A  AND  B  ARE  VECTORS  OF  LENGTH  3.  D0TT31 

C  D0TT31 

IMPLICIT  REAL»8  (A-H.O-Z)  DOTT31 

DIMENSION  A(3)  .  B (3)  ,  C(3,3)  D0TT31 

DO  10  1=1,3  DOTT31 

DO  10  J=1 ,3  DOTT31 

10  C(I.J)  =  A(I)*B(J)  D0TT31 

RETURN  D0TT31 

END  D0TT31 


& 


a 


& 

$9 


m 


m 


SUBROUTINE  DOTT33  (A,B,C) 


BEV  17 


PERFORMS  MATRIX  MULTIPLICATION  C  =  AB‘ 
WHERE  A,  B  AND  C  ARE  ALL  3X3  MATRICEES. 


IMPLICIT  REAL *8  (A-H.O-Z) 

DIMENSION  A(3,3)  ,  B(3,3)  .  C(3,3) 

DO  10  1=1,3 

DO  10  J=1 ,3 

10  C(I,J)  =  ACI . 1) *B( J. 1)  +  A ( I , 2) *B ( J , 2)  ♦  A(I ,3) *B(J,3) 
RETURN 
END 


D0TT33 

01/03/77DOTT33 

D0TT33 

D0TT33 

D0TT33 

D0TT33 

D0TT33 

DOTT33 

D0TT33 

DOTT33 

D0TT33 

D0TT33 


«**.•*<■ 


SOBBOOTIME  DOT31  (A.B.C) 


BET  17 


PERFORMS  MATBIX  MOLT I PL I CAT I ON  C  =  A’B 

WHERE  A  IS  A  3X3  MATBIX,  AND  B  AND  C  ABE  VECTORS  OF  LENGTH  3 


DOT31 

01/03/77D0T31 

DOT31 


IMPLICIT  BEAL»8  (A-H,0-Z) 


DIMENSION  A(3 ,3) 

C ( 1)  =  A ( 1 , 1 ) *B ( 1 ) 
C (2)  =  A( 1 , 2) *B ( 1 ) 
C (3)  =  A(1 ,3)*B(1) 
RETORN 
END 


B(3)  ,  C (3) 

►  A(2 , 1) *B(2) 

►  A ( 2 , 2 ) »B(2) 

►  A(2 ,3) *B (2) 


A(3 , 1) *B (3) 
A(3 , 2) *B (3) 
A(3 , 3) *B (3) 


D0T31 

DOT31 

DOT3I 

DOT31 

DOT31 

DOT31 

D0T31 

D0T31 

D0T31 


£ 

1 
Vic 
*  *.r 


SUBROUTINE  DOT33  (A.B.C)  DOT33 

C  REV  17  01/03/77DOT33 

C  PERFORMS  MATRIX  MULTIPLICATION  C  =  A’B  DOT33 

C  WHERE  A,  B  AND  C  ARE  ALL  3X3  MATRICEES.  DOT33 

C  DOT33 

IMPLICIT  REAL»8  (A-H.O-Z)  DOT33 

DIMENSION  A(3 ,3)  ,  «(3,3)  ,  C(3,3)  DOT33 

DO  10  1=1,3  D0T33 

DO  10  J=1 ,3  D0T33 

10  C(I,J)  =  A( 1 , I) *B( 1 , J)  ♦  A(2 , I) »B(2 , J)  ♦  A(3 . I) *B (3 , J)  D0T33 

RETURN  D0T33 

END  D0T33 


10 


20 


99 


S0BB00TIME  DBCIJX  (D.ANG.ID.HT, J)  DBCIJK 

REV  18  02/24/78DBCIJK 

IMPLICIT  REAL*8  (A-H.O-Z)  DBCIJK 

DIMENS IOM  D(9,22) ,HT(9,42) ,ANG(3,22) , ID (4,22) ,T1(9) ,T2(9)  DBCIJK 

M  =  ID(4 , J)  DBCIJK 

IF  (M.NE.O)  GO  TO  10  DBCIJK 

CALL  DBCYPB  (D(l , J) , AMG(1 , J) , ID (1 , J) )  DBCIJK 

GO  TO  99  DBCIJK 

CALL  DBCYPB  (T1 ,AMG(1 ,J) ,ID(I ,J) )  DBCIJK 

IF  (M.LT.O)  GO  TO  20  DBCIJK 

CALL  MAT33  (T1,D(1,M) ,D(1,J)>  DBCIJK 

GO  TO  99  DBCIJK 

M  =  -M  DBCIJK 

CALL  D0T33  (HT ( 1 ,2*J-3) ,D( 1 ,M)  ,D ( 1 , J) )  DBCIJK 

CALL  MAT33  (T 1 ,D(1 ,J) ,T2)  DBCIJK 

CALL  MAT33  (HT(1 ,2*J-2) ,T2,D(1 , J) )  DBCIJK 

BETORN  DBCIJK 

END  DBCIJK 


d 


4 

$ 

ss 


SUBROUTINE  DRCQUA(DC.Q) 

REV  III.? 

COMPUTES  DIRECTION  COS I HE  MATRIX  FBOM  QUATERHIOHS 
IMPLICIT  REAL*8(A-H,0-Z) 

DIMENSION  DC (3,3) ,Q(4) 

C  =  Q(l)»«2  -  0(2) **2  -  Q(3) »»2  -  Q(4>«*2 
DO  12  I  =  1.3 
DO  10  J  *  1.3 

10  DC  (I ,  J)  =  2 . 0*Q ( I 1 )  «Q(J+1) 

12  DC ( I , I )  *  DC(I,I)  +  C 
E  =  Q(l)  ♦  Q ( 1 ) 

DO  14  I  =  1.3 
J  =  1  +  MOD(I ,3) 

K  =  1  ♦  MOD  (Id  ,3) 

D  =  E*Q(I+1) 

DC(K.J)  =  DC(X, J)  -  D 
14  DC(J.K)  =  DC (J ,K)  ♦  D 
DO  18  I  =1,3 
DO  18  J  =  1,3 

18  IF (DABS (DC (I , J) ) . GT. 1 . ODO) DC (I , J)  =  DSIGH( 1 .ODO ,DC (I , J) ) 
RETURN 
END 


DRCQUA 

07/31/85JTF785 

DRCQUA 

DRCQUA 

DRCQUA 

JTF785 

DRCQUA 

DRCQUA 

DRCQUA 

DRCQUA 

DRCQUA 

DRCQUA 

DRCQUA 

DRCQUA 

DRCQUA 

DRCQUA 

DRCQUA 

DRCQUA 

DRCQUA 

DRCQUA 

DRCQUA 

DRCQUA 


SUBBOUTIME  DRCYPB  (D.A.ID)  DRCYPB 

c  RET  IV  07/23/86TW0PI 

C  SETS  UP  3X3  DIRECTION  COSINE  MATRIX  FOB  GIVEN  YAW, PITCH  AND  BOLL.  DRCYPB 
c  DRCYPB 

C  ARGUMENTS :  DRCYPB 

C  D:  3X3  DIRECTION  COSINE  MATRIX  TO  BE  COMPUTED.  PRCYPR 

C  A:  ARRAY  OF  LENGTH  3  CONTAINING  ROTATATION  ANGLES  (DEGREES) .  DRCYPB 

C  II:  AXIS  OF  ROTATION  FOR  1ST  ANGLE  (1,2,3  =  X,Y,Z)  DRCYPB 

C  12:  AXIS  OF  ROTATION  FOR  2ND  ANGLE  (1,2,3  =  X,Y,Z)  DRCYPB 

C  13:  AXIS  OF  ROTATION  FOR  3RD  ANGLE  (1,2,3  *  X,Y,Z)  DRCYPB 

c  DRCYPB 

IMPLICIT  REAL » 8  (&-H.O-Z)  DRCYPB 

COMMON/CNSNTS/  PI ,BADI AN, G.THIBD.EPS (24) ,  DRCYPB 

«  UNITL,UNITM,UNITT,GRAVTY(3) .TWOPI  TWOPI 

DIMENSION  D(3,3) ,A(3) ,ID(3) ,T(3.3) ,B(3) ,S(3)  DRCYPB 

IDSUM  =  ID ( 1 )  ♦  ID ( 2 )  +  10(3)  DRCYPB 

DO  12  1=1,3  DRCYPB 

B ( I )  =  A ( I ) » RADI AN  DRCYPB 

DO  11  J=1 ,3  DRCYPR 

11  D(I,J)  =  0.0  DRCYPR 

12  D (I , I)  =  1.0  DRCYPB 

DO  30  N=1 ,3  DRCYPR 

IDN  =  IABS(ID(N) )  DRCYPR 

M  =  4  -  IDN  DRCYPR 

IF  (ID(N).LT.O)  M  =  IDSUM-  ID(N)  -  2  DRCYPR 

IF  (B(M) . EQ.O.O)  GO  TO  30  DRCYPR 

CALL  ROT  (T,IDN,B(M) )  DRCYPB 

DO  23  J= 1 ,3  DRCYPR 

DO  21  K=1 ,3  DRCYPR 

S(K)  =  D(K, J)  DRCYPR 

21  D(K.J)  =  0.0  DRCYPB 

DO  22  1=1,3  DRCYPR 

DO  22  K= 1,3  DRCYPR 

22  D(I,J)  =  D ( I , J)  +  T(I,K)*S(K)  DRCYPB 

23  CONTINUE  DRCYPR 

30  CONTINUE  DRCYPR 

RETURN  DRCYPR 

END  DRCYPB 


I 


c 

c 

c 

c 
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SUBROUTINE  DRIFT  DRIFT 

REV  IV  07/24/86SLIP 

CORRECTS  FOR  DRIFT  IN  CONSTRAINED  JOINTS  DRIFT 

DRIFT 

DRIFT 

IMPLICIT  RE«I*8(A-H,0-Z)  DRIFT 

COMMON/CONTRL/  TIME , NSEG , NJNT , NPL , NBLT , NBAG , NVEH , NORND ,  DRIFT 

*  NS , NQ , NSD , NFLX , NHRNSS , NWI NDF , NJNTF , NPRT ( 36 ) , HPG  DRIFT 

COMMON/SGMNTS/  D(3,3,30) ,WMEG(3,30) ,WMEGD(3,30) ,U1(3,30) ,U2(3,30) .DRIFT 

*  SEGLP(3,30) ,SEGLV(3,30) ,SEGLA(3,30) ,NSTM(30)  DRIFT 

COMMON/ DESCRP/  PHI (3,30) ,W(30) ,BW(30) ,SR(4,60) ,HA(3.60) ,HB(3,60) ,  SLIP 

»  RPHK3.30)  ,HT(3,3,0O)  ,SPRIHG(5 ,90)  ,VISC(7,90)  ,  DRIFT 

»  JNT(30) ,IPIN(30) ,ISING(30) , IGL0B(30) ,J0INTF(30)  DRIFT 

COMMON/CEULER/  IEULER(30) ,HIR(3 , 3 , 90) , ANG(3 ,30) . ANGD(3 ,30) ,  DRIFT 

*  FE(3,30) ,TQE(3,30) ,C0NST(5,30)  DRIFT 

COMMON/CNSNTS/  PI , RADIAN ,G, THIRD .EPS (24) ,  DRIFT 

»  UNITL,UNITM,UNITT,GRAVTY(3) , TWOPI  TWOPI 

COMMON/TEMPVS/  T1 (3) ,T2 (3) ,T3 (3) ,T4 (3) ,TP (3 , 3)  ,H1  (3)  ,H2 (3)  DRIFT 

IF  (NJNT.EQ.O)  GO  TO  51  DRIFT 

DO  50  J= 1 , NJNT  DRIFT 

K  =  IABS ( JNT (J) )  DRIFT 

IF  (K.EQ.O)  GO  TO  50  DRIFT 

IF  (TSING(J+1) .LT.O)  GO  TO  50  DRIFT 

DRIFT 

M  »  0  DRIFT 

IF  (IPIN(J) . EQ . 1 )  M  *  4  DRIFT 

IF  (IPIN(J) . EQ. 6)  M  =  4  SLIP 

IF  (IPIN(J) . EQ. 7)  M  =  4  SLIP 

IF  (IABS(IPIN(J) ) . NE.4)  GOTO  15  DRIFT 

IF  (IEULER(J) .EQ. 1)  M=  2  DRIFT 

IF  (IEULER(J) . EQ.2)  M=  3  DRIFT 

IF  (IEULER(J) .EQ.3)  M=  1  DRIFT 

IF  (IEULER(J) .EQ.4)  M  =  4  DRIFT 

IF  (IEULER(J) . EQ.5)  M  =  4  DRIFT 

IF  (IEULER(J) .EQ.6)  M=  4  DRIFT 

15  IF  (M. EQ. 0)  GO  TO  50  DRIFT 

IF (M.EQ. 4)G0  TO  23  DRIFT 

IF (M.NE. 3)(30  TO  21  DRIFT 

CALL  EJOINT (- 1 , J)  DRIFT 

CALL  CROSS(HIR(l,2,2»J+29) ,HIR( 1 , 1 ,2»J+29) ,T1)  DRIFT 

DO  17  I  =  1,3  DRIFT 

H1(I)  =  CONST (4 , J) *HIR(I , 1 ,2»J+29)  +  C0NST(5 , J) *T1 (I)  DRIFT 

17  H2(I)  =  HIR(I ,3 ,2»J+30)  DRIFT 

GO  TO  25  DRIFT 

21  DO  22  I  =  1.3  DRIFT 

H1(I)  =  HI R ( I ,M,2»J+29)  DRIFT 

22  H2(I)  =  HIR(I ,M+1 ,2»J+30)  DRIFT 

GO  TO  25  DRIFT 

23  DO  24  I  =  1,3  DRIFT 

HKD  =  HB(I,2*J-1)  DBIFT 
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24  H2(I)  =  HB(I ,2*J) 

«•  ADJUST  DC  MATRIX  FOB  CONSTRAINED  JOINTS  »» 

25  CALL  DOT31 (D(l , 1 ,K) ,H1 ,T1) 

CALL  MATA 1  (D( 1 , 1 , J+l) ,TI ,T2) 

CT  =  T2 ( 1) *H2 ( 1)  +  T2 (2) »H2 (2)  ♦  T2(3)*H2(3) 

IF(M.GE.3)QO  TO  28 

ST  =  1 . O/DSQRT ((1.0  -  CT)»(1.0  +  CT)> 

DO  27  I  =  1,3 

27  T2 (I)  =  (H2(I)  -  CT*T2 (I) ) »ST 
CT  =  1.0/ST 

28  CALL  CROSS (H2.T2.T3) 

DO  30  L=1 ,3 

CALL  CROSS  (T3,D(1 ,L, J+l) ,T4) 

ST  =  T3 ( 1) *D( 1 ,L, J+l)  ♦  T3 (2) *D (2 , L , J+ 1)  +  T3(3)»D(3,L,J+1) 
ST  =  ST/ (1.0  ♦  CT) 

DO  30  1=1,3 

30  D(I ,L, J+l)  =  CT*D(I,L,J+1)  -  T4(I)  +  ST«T3(I) 

*»  RENORMALIZATION  OF  DIRECTION  COSINE  MATRIX  BT  »« 

»«  AVERAGING  MATRIX  AND  TRANSPOSE  OF  ITS  INVERSE  •* 

DO  33  ITER=  1,10 

CALL  CFACTT  (D( 1 , 1 ,J+1) .TP.DET) 

DO  32  L  =  1,3 
DO  32  I  =  1,3 

D(I ,L, J+l)  =  0. 5* (D(I , L , J+l) +TP(L, I) /DET) 

32  IF  (DABS (D(I,L,J+1)) . LT . EPS ( 15) )  D(I, L, J+l)  =  0.0 
IF  ( DABS (DET- 1.0) .LT.EPS(6))  GO  TO  41 

33  CONTINUE 

WRITE  (6,34)  J, TIME, DET 

34  FORMAT  (44H0  DRIFT  RENORMALIZATION  DID  NOT  CONVERGE  FOR. 

»  10H  JOINT  N0..I3.7H  TIME  =,F10.6,6H  DET  =,F10.6) 

««  ADJUST  WMEG  FOR  CONSTRAINED  JOINTS  •• 

41  IF(M.NE.4)G0  TO  43 

HW  =  H2 (1) »WMEG( 1 , J+l)  -  HI ( 1) «WMEG( 1 ,K) 

«  ♦  H2 (2)  *WMEG(2 , J+ 1)  -  HI (2) « WMEG (2 ,K) 

»  ♦  H2  (3)  *  WMEG  (3  ,  J  +  1 )  -  HI  (3)  » WMEG  (3  ,K) 

CALL  D0T31  (D(l , 1 ,K) , WMEG (I ,K) ,TI) 

CALL  MAT31  ( D ( 1 , 1 , J  + 1 ) , T 1 , WMEG ( 1 , J  + 1 ) ) 

DO  42  1=1,3 

42  WMEG(I,J*1)  =  WMEG(I,J*1)  ♦  HW«H2(I) 

GO  TO  50 

43  IF (M. NE . 3) GO  TO  47 

CALL  D0T31 (D( 1 , 1 ,K) ,HIB(1 ,2,2«J+29) ,T1) 

CALL  MAT31 (D(l , 1 ,J+1) ,T1,H1) 

GO  TO  48 
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DBIFT 
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DRIFT 

DRIFT 
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DRIFT 

DRIFT 

DBIFT 

DRIFT 

DBIFT 

DRIFT 
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DRIFT 

DBIFT 

DRIFT 

DRIFT 
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47  CALL  MAT31(D(1,1,J+1) ,T1,T2) 

CALL  CB0SS(T2,H2,H1) 

48  CALL  D0T31 (D(l , 1 ,K) ,WMEG(1 ,K) ,T1) 
CALL  MAT31 (D( 1 , 1 , J+1) ,T1 ,T2) 

HW  =  Hl(l)«  (T2 ( 1)  -  WMEG( 1 ,  J+D  ) 

*  ♦  HI  (2)  *  (T2 (2)  -  WMEG(2 , J+1)  ) 

»  +  HI  (3)  *  (T2 (3)  -  WMEG(3, J+1)  ) 

DO  49  I  =  1,3 

49  mfEG(I,J+l)  =  WMEG(I ,  J+1)  +  HW*H1(D 

50  CONTINUE 

51  RETURN 
END 
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SUBROUTINE  DSETD (D,TH,T)  DSETD 

REV  IV  O7/23/80TWOPI 

UPDATES  A  DIRECTION  COSINE  MATRIX  (D)  DSETD 

USING  AN  INCREMENTAL  ANGULAR  MOTION  (TH) .  DSETD 

ARGUMENTS  D:  3X3  DIRECTION  COSINE  MATRIX  TO  BE  UPDATED.  DSETD 

TH:  3  COMPONENTS  OF  INCREMENTAL  ANGULAR  MOTION  DSETD 

ABOUT  LOCAL  X,Y  AND  Z  AXIS  RESPECTIVELY.  DSETD 

T:  MAGNITUDE  OF  VECTOR  TH  COMPUTED  BY  ROUTINE.  DSETD 

DSETD 

IMPLICIT  REAL»8(A-H,0-Z)  DSETD 

DIMENSION  D (3 .3)  ,TH(3)  ,S(3)  , TEMPO, 3)  DSETD 

COMMON/CNSNTS/  PI .RADI AN, G, THIRD, EPS (24) .  DSETD 

*  UNITL,UNITM,UNITT,GRAVTY(3) ,TWOPI  TWOPI 

T=DSQRT(TH(1)*»2VTH(2)«*2+TH(3)»*2)  DSETD 

IF (T.EQ.O.) RETURN  DSETD 

ST=DSIN(T)  DSETD 

CT=DCOS (T)  DSETD 

STT=ST/T  DSETD 

CTT=STT»*2/(1.+CT)  DSETD 

DO  10  J= 1 , 3  DSETD 

S ( 1 ) =-TH(3) *D (2 , J) +TH(2) »D(3 , J)  DSETD 

S (2) =  TH(3) *D( 1 , J) -TH( 1) *D(3,J)  DSETD 

S (3) =-TH(2) «D ( 1 , J) +TH( 1) *D (2 , J)  DSETD 

DTT= (TH( 1) *D( 1 , J) +TH(2) *D(2 , J) +TH(3) *D(3 , J) ) *CTT  DSETD 

DO  5  K=  1 ,3  DSETD 

5  D(K,J)=D(K,J) »CT-STT«S (K) +TH(K) »DTT  DSETD 

10  CONTINUE  DSETD 

DSETD 

RENORMALIZATION  OF  DIRECTION  COSINE  MATRIX  DSETD 

BY  AVERAGING  MATRIX  AND  TRANSPOSE  OF  ITS  INVERSE.  DSETD 

DSETD 

DO  23  ITER= 1 , 10  DSETD 

CALL  CFACTT (D , TEMP , DET)  DSETD 

DO  22  1=1,3  DSETD 

DO  22  J=1 ,3  DSETD 

D ( I  , J)  =  0 . 5» (D(I , J) +TEMP (J , I) /DET)  DSETD 

22  IF  (DABS(D(I  ,J) )  .LT.EPSU5) )  D(I,J)=0.0  DSETD 

IF  (DABS (DET- 1 .0) . LT. EPS (6) )  GO  TO  24  DSETD 

23  CONTINUE  DSETD 

WRITE  (6,27)  DET  DSETD 

27  FORMAT ( ' 0  DSETD  RENORMALIZATION  DID  NOT  CONVERGE,  DET  = ’ , 1PD25 . 15) DSETD 

24  RETURN  DSETD 

END  DSETD 


SUBROUTINE  DSETQ (E , TH , ES , EC , D)  DSETQ 

REV  IV  07/23/88TW0PI 

COMPUTES  NEW  DIRECTION  MATRIX  (D) .  GIVEN  ORIGINAL  MATRIX  (E)  DSETQ 

AND  INCREMENTAL  MOTION  EXPRESSED  IN  QUATERNION  FORM.  DSETQ 

DSETQ 

ARGUMENTS :  DSETQ 

DSETQ 

E  :  ORIGINAL  DIRECTION  COSINE  MATRIX.  DSETQ 

TH  :  COMPONENTS  OF  Q  (  UX  SIN  A/2,  UY  SIN  A/2,  UZ  SIN  A/2)  DSETQ 
ES  :  SIN«»2 (A/2)  DSETQ 

EC  :  COS  (A/ 2)  DSETQ 

D  :  NEW  DIRECTION  COSINE  MATRIX.  DSETQ 

DSETQ 

IMPLICIT  REAL»8 (A-H.O-Z)  DSETQ 

DIMENSION  D(3,3)  ,TH(3)  ,S(3)  , TEMPO, 3)  ,E(3,3)  DSETQ 

COMMON/CNSNTS/  PI .RADIAN, G, THIRD , EPS (24) ,  DSETQ 

»  UNITL,UNITM,UNITT,GRAVTY(3) .TWOPI  TWOPI 

CT  =  1.0  -  2 . 0*ES  DSETQ 

DO  10  J=  1 , 3  DSETQ 

S(l)  =  TH(2)*E(3.J)  -  TH(3) *E (2 , J)  DSETQ 

S (2)  =  TH(3) *E ( 1 , J)  -  TH( 1) *E (3 , J)  DSETQ 

S (3)  =  TH( 1) *E (2 , J)  -  TH(2) * E ( 1 , J)  DSETQ 

DTT  =  TH( 1 ) »E ( 1 , J)  ♦  TH(2) *E (2 , J)  ♦  TH(3)*E(3,J)  DSETQ 

DO  5  K= 1 , 3  DSETQ 

5  D(K, J)  =  E(K, J) «CT  +  2.0*(TH(X)#DTT  -  EC»S(K))  DSETQ 

10  CONTINUE  DSETQ 

DSETQ 

RENORMALIZATION  OF  DIRECTION  COSINE  MATRIX  DSETQ 

BY  AVERAGING  MATRIX  AND  TRANSPOSE  OF  ITS  INVERSE.  DSETQ 

DSETQ 

DO  23  ITER= 1 , 10  DSETQ 

CALL  CF ACTT ( D , TEMP , DET )  DSETQ 

DO  22  1=1,3  DSETQ 

DO  22  J= 1 , 3  DSETQ 

D (I . J)  =  0.5»(D(I,J) +TEMP (J, I) /DET)  DSETQ 

22  IF  (DABS(D(I , J) ) .LT.EPS(15) )  D(I,J)=0.0  DSETQ 

IF  (DABS (DET- 1 .0)  . LT.EPSO) )  GO  TO  24  DSETQ 

23  CONTINUE  DSETQ 

WRITE  (6,27)  DET  DSETQ 

27  FORMAT ( ' 0  DSETQ  RENORMALIZATION  DID  NOT  CONVERGE,  DET  = ' , 1PD25 . 15) DSETQ 

24  RETURN  DSETQ 

END  DSETQ 


• 
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■ 

SUBROUTINE  DSMSOL  (A.KK.LL) 

DSMSOL 

C 

BEV  03 

07/08/74DSMSOL 

r 

SOLVES  A  SET  OF  SIMULTANEOUS  LINEAB  EQUATIONS  AX=B. 

DSMSOL 

DSMSOL 

£ 

ARGUMENTS : 

DSMSOL 

c 

A:  2-DIMENSIONAL (KK.KK* I)  MATRIX  OF  COEFFICIENTS. 

DSMSOL 

W  c 

KX:  NUMBER  OF  EQUATIONS  AND  UNKNOWNS. 

DSMSOL 

5r  c 

LL:  1ST  DIMENSION  OF  A  IN  CALLING  PROGRAM. 

DSMSOL 

C 

DSMSOL 

fsf  c 

CALLING  PROGRAM  SETUP: 

DSMSOL 

JO?  c 

A(I.J)  FOR  I ,  J=1 ,KK 

DSMSOL 

A(I . KK*1)  =  B ( I )  FOR  1=1. KK 

DSMSOL 

m  n 

THE  SOLUTION  X  IS  RETURNED  IN  COLUMN  KK+1  OF  A. 

DSMSOL 

P5?  r. 

MATRIX  A  IS  DESTROYED  BY  SUBROUTINE. 

DSMSOL 

c 

DSMSOL 

IMPLICIT  REAL*8 (A-H.O-Z) 

DSMSOL 

rc 

DIMENSION  A(LL , 1) 

DSMSOL 

K 

N  =  KK 

DSMSOL 

• 

N1  =  N+l 

DSMSOL 

DO  50  L=1.N 

DSMSOL 

r-K 

LI  =  L+l 

DSMSOL 

s» 

BIG  =  0.0 

DSMSOL 

j® 

DO  25  I=L ,N 

DSMSOL 

L‘A 

IF  (DABS (A ( I, L)) .LE. DABS (BIG))  GO  TO  25 

DSMSOL 

■ 

X  =  I 

DSMSOL 

BIG  =  A ( I , L ) 

DSMSOL 

C& 

25  CONTINUE 

DSMSOL 

$ 

IF  (BIG. NE. 0.0)  GO  TO  30 

DSMSOL 

■jSi 

WRITE  (6,26) 

DSMSOL 

26  FORMAT ( ’ 0  DSMSOL  MATRIX  SINGULAR,  PROGRAM  TERMINATED.’) 

DSMSOL 

ijj 

STOP  4 1 

DSMSOL 

30  BIG  =  1.0/BIG 

DSMSOL 

DO  40  J=L ,N1 

DSMSOL 

SJ 

B  =  A(K.J) 

DSMSOL 

F 

A(K, J)  =  A (L, J) 

DSMSOL 

t* 

40  A(L, J)  =  B»BIG 

DSMSOL 

• 

IF  (L.EQ.N)  GO  TO  50 

DSMSOL 

ES 

DO  48  1=11, N 

DSMSOL 

RjK 

IF  ( A ( I ,L) .EQ.O.O)  GO  TO  48 

DSMSOL 

kVO 

DO  45  J=L1 ,N1 

DSMSOL 

PQ5 

45  A(I,J)  =  A(I,J)-A(I,L)*A(L,J) 

DSMSOL 

kS5 

48  CONTINUE 

DSMSOL 

• 

50  CONTINUE 

DSMSOL 

H? 

IF  (N.EQ.l)  GO  TO  71 

DSMSOL 

tv 

N2  =  N-l 

DSMSOL 

wt 

DO  60  L=  1 ,  N2 

DSMSOL 

I  =  N-L 

DSMSOL 

fci 

LI  =  1  +  1 

DSMSOL 

• 

DO  60  J=L1,N 

DSMSOL 

fyT' 

r-\; 

60  A(I,N1)  =  A(I,N1)-A(I,J)*A(J,N1) 

DSMSOL 

F 

r/’ 
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rv 

F 

y*  v . . .  — . . 
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SUBROUTINE  DZP(N,X,GG,E,R,M) 


$ 

n 


m 


c 

c 

c 

c 

c 


c 

c 

c 


RET 

COMPUTES  THE  STATE  VARIABLES  (X)  FROM  THE  PARAMETRIC 
IN  THE  INTEGRATION  ROUTINE  DINT.  ALSO  EVALUATES  THE 
WEIGHTS  (E)  IF  M  IS  NOT  ZERO. 

IMPLICIT  REAL* 8  (A-H.O-Z) 

DIMENSION  X(l) ,GG(5,I) ,E(3,1) 

COMMON/CNSNTS/  PI .RADIAN, G.THIRD .EPS (24) . 

*  UNITL,UNITM,UNITT,GRAVTY(3) ,TWOPI 

CALL  ELTIME(1 ,5) 

IF(M.NE.O)  GO  TO  10 

COMPUTE  STATE  VARIABLES  ONLY. 


DO  5 
5  X(I) 

* 

« 

GO  TO  90 


1  =  1  ,N 

=  GG( 1 , I)  ♦  R* (GG(2 , I) *E( 1 , I) 

♦  R» (GG(3 . I) *E(2 , I) 

♦  R* (GG (4,1) *E(3 , I)  ))) 


C 

C 

c 


COMPUTE  EXPONENTIAL  WEIGHTS  AND  STATE  VARIABLES. 

10  DO  50  1  =  1, N 

E(  1 , 1)  =  1.0 
E (2 . 1)  =  0.5 
E (3 , I)  =  THIRD 
IF  (GG(5,I) .EQ.O.O)  GO  TO  50 
Z  =  R*GG(5,I) 

W  =  0. 

IF  (DABS (Z) .GT. 0.004)  GO  TO  20 
W  =  4. 

A  =  E  (3 , 1) 

E(3 , 1)  =  0. 

15  E(3,I)  =  E (3 , I) +A 
A  =  A*Z/W 
W  =  W+1.0 

IF(E(3,I)+A.NE.E(3,I))  GO  TO  15 
E(2 , I)  =  0 . 5  +  0 . 5»Z*E (3 , 1) 

E(l, I)  =  1 . +Z*E(2 , I) 

GO  TO  50 

20  IF (Z.GT. -40 . )  W  =  DEXP(Z) 

Ed, I)  =  (W-l.J/Z 
E(2 , 1)  =  (Ed  , I)  - 1 . ) /Z 
E (3 , 1 )  =  (2 . «E(2 , 1) -1 . ) /Z 
50  X(I)  =  GG (1,1)  ♦  R# (GG(2 , I) *E (1 , I) 

»  ♦  R* (GG(3 , I) *E (2 , I ) 

*  ♦  R*(GG(4,I) *E(3,I)  ))) 
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DZP 

IV  07/23/86TW0PI 
FORM  ASSUMED  DZP 

EXPONENTIAL  DZP 
DZP 
DZP 
DZP 
DZP 
DZP 
TWOPI 
DZP 
DZP 
DZP 
DZP 
DZP 
DZP 
DZP 
DZP 
DZP 
DZP 
DZP 
DZP 
DZP 
DZP 
DZP 
DZP 
DZP 
DZP 
DZP 
DZP 
DZP 
DZP 
DZP 
DZP 
DZP 
DZP 
DZP 
DZP 
DZP 
DZP 
DZP 
DZP 
DZP 
DZP 
DZP 
DZP 
DZP 
DZP 
DZP 
DZP 


90  CALL  ELTIME(2,S) 
RETURN 
END 


SUBROUTINE  EDEPTH  (A,B,XM,T,Y,XA,XB,XL,XU) 


REV  IV 


EDEPTH 

07/23/86TW0PI 


DETERMINES  XA  AND  XB,  THE  POINTS  OF  MAXIMUM  PENETRATION  OF  TWO 
INTERSECTING  ELLIPSOIDS  A  AND  B. 

ARGUMENTS  A.B.XM.T  AND  X  SAME  AS  FOR  SUBROUTINE  INTERS. 
ARGUMENTS  XL  AND  XU,  IF  NONZERO,  ARE  FINAL  RESULTS  OF  LAST  CALL. 


EDEPTH 
EDEPTH 
EDEPTH 
EDEPTH 
EDEPTH 

IMPLICIT  REAL* 8  (A-H.O-Z)  JJJ2J 

DIMENSION  A(3,3) ,B(3,3) ,XM(3) ,Y(3) ,XA(3) ,XB(3)  EDEPTH 

COMMON/CONTRL/  TIME,NSEG,NJNT,NPL,NBLT , NBAG , NVEH , NGBND ,  EDEPTH 

*  NS , NQ , NSD . NFLX , NHRNSS , NWINDF , NJNTF , NPRT (36) , NPG  PAGE 

COMMON/CNSNTS /  PI .RADIAN, G.THIRD.EPS (24) ,  EDEPTH 

*  UNITL,UNITM,UNITT,GRAVTY(3) .TWOPI  TWOPI 

DIMENSION  Cl (3,4) ,C2(3,4) ,C3(3,4) ,XBM(3) ,PXBL(3) ,PXAU(3) ,AB(3.3)  EDEPTH 
DIMENSION  AXA(3) ,BXBM(3) ,PXAL(3) ,PXBU(3)  EDEPTH 

EQUIVALENCE  (XBM( 1) ,C1 ( 1 , 4) ) ,  (PXBL(l) ,C2(1 ,4) ) ,  (PXAU(l) ,C3(1 ,4) )EDEPTH 

EDEPTH 

INITIAL  GUESSES  EDEPTH 

XA  =  Y/T  EDEPTH 

XB  =  M+(Y-M)/T  EDEPTH 

L  =  - IXB-XA! / ! AXA!  EDEPTH 

U  =  - ! XB-XA I / ! B (XB-M)  !  EDEPTH 


D1  ■  0.0 

D2  =  0.0 

DO  9  1=1,3 

XA(I)  =  Y(I)/T 

XBM(I)  =  (Y(I)-XM(I))/T 

XB  (I)  =  XBM(I) +XM(I) 

9  D1  =  D1+(XB(I)-XA(I))*»2 

IF  (DABS(T-l.O) .LE.EPS(0))  GO  TO  31 
ITER  =  0 

CALL  MAT33  (A.B.AB) 

IF  (XL.NE.O.O)  GO  TO  11 

IF  (XU.NE.O.O)  GO  TO  11 

D3  =  0.0 

DO  10  1=1,3 

AXA ( I )  =  A(I , 1) *XA( 1) 

*  ♦  A(I ,2) *XA(2) 

»  ♦  A(I ,3) *XA(3) 

D2  =  D2  ♦  AXA(I)»*2 

BXBM(I)  =  B(I,1)*XBM(1) 

«  ♦  B(I ,2) *XBM(2) 

«  +  B ( I ,3) *XBM(3) 

10  D3  =  D3+BXBM(I)**2 
XL  =  -DSQRT(D1/D2) 

XU  =  -DSQRT(D1/D3) 


START  OF  ITERATION 


EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 


t*L 

t*J 

»•] 

rT 

tHS 


11  ITEB  =  ITER+1 

IF  (NPRT(17) .NE.O)  WRITE  (6,12)  ITER.XL.XU.XA.XB 

12  FORMAT ( ’  EDEPTH  ITER* , 16 .8Q14 . 6) 

IF  (ITER. LE. 50)  GO  TO  14 

WRITE  (6,13) 

13  FORMAT (’  EDEPTH  ITERATIOH  DID  HOT  COHTERGE ' ) 

GO  TO  31 

FORM  MATRICES 
Cl  =  LUAB  +  LA  +  UB 
C2  =  Cl 
C3  =  Cl’ 

14  XLAU  -  XU* XL 
DO  22  1=1,3 
XBM(I)  =  0.0 
DO  22  J=1 ,3 

Cl  (I , J)  =  XLAU*AB(I,J)  +  XL*A(I , J)  ♦  XU«B(I,J) 

C2  (I ,  J)  =  Cl(I.J) 

C3 ( J , I )  =  Cl(I.J) 

22  XBM(I)  =  XBM(I)  -  XL*A(I , J) *XM(J) 

SOLVE  FOR  (XB-M) 
Cl(XB-M)  =  -LAM 


CALL  DSMS0L(C1 ,3,3) 


EVALUATE 
XB  =  (XB-M) +M 
B(XB-M) 

AXA 

C13  =  ( 1-XA’ AXA) /2 

C23  =  ( 1- (XB-M) ’B (XB-M) ) /2 


C13  =  0.0 

C23  =  0.0 

DO  23  1=1,3 

XB ( I )  =  XBM(I) +XM(I) 

BXBM(I)  =  BCI , 1) *XBM(1) 

*  +  B(I ,2) *XBM(2) 

«  +  B(I ,3) *XBM(3) 

23  XA(I)  =  XB(I)  ♦  XU*BXBM(I) 
DO  24  1=1,3 

AXA(I)  =  A ( I , 1 ) *XA( 1) 

«  ♦  A ( I ,2) *XA(2) 

»  +  A(I ,3) *XA(3) 

C13  =  C13  ♦  XA(I) *AXA(I) 
C23  =  C23  ♦  XBM(I) *BXBM(I) 

24  PXBL(I)  =  -AXA(I) 

C13  =  ( 1 . 0-C13) /2 . 0 


L 


EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 
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C23  = 

(1.0-C23J/2.0 

« 

DXB 

EDEPTH 

EDEPTH 

SOLVE 

FOB  --- 

EDEPTH 

* 

DL 

EDEPTH 

EDEPTH 

*  DXB 

EDEPTH 

C2 - 

=  -AXA 

EDEPTH 

*  DL 

EDEPTH 

EDEPTH 

CALL 

DSMSOL (C2 ,3,3) 

EDEPTH 

EDEPTH 

CALCULATE 

EDEPTH 

DXA 

DXB 

DXB 

EDEPTH 

- = 

— -  +  UB--- 

EDEPTH 

DL 

DL 

DL 

EDEPTH 

EDEPTH 

» 

DXA 

EDEPTH 

Cll  = 

XA '  A - 

EDEPTH 

» 

DL 

EDEPTH 

EDEPTH 

» 

DXB 

EDEPTH 

C21  = 

(XB-M)  ’B— 

EDEPTH 

• 

DL 

EDEPTH 

EDEPTH 

Cll  = 

0.0 

EDEPTH 

C21  * 

0.0 

EDEPTH 

DO  25 

1  =  1,3 

EDEPTH 

PXAL(I)  =  B(I , 1) *PXBL(1) 

EDEPTH 

« 

+  B(I ,2) «PXBL(2) 

EDEPTH 

* 

+  B(I ,3) »PXBL(3) 

EDEPTH 

PXAL(I)  =  PXBL(I)  +  XU*PXAL(I) 

EDEPTH 

Cll  = 

Cll  ♦  AXA(I) *PXAL(I) 

EDEPTH 

C21  = 

C21  +  BXBM(I) »PXBL(I) 

EDEPTH 

25  PXAU(I)  =  -BXBM(I) 

EDEPTH 

EDEPTH 

« 

DXA 

EDEPTH 

SOLVE 

FOB  — 

EDEPTH 

« 

DU 

EDEPTH 

EDEPTH 

*  DXA 

EDEPTH 

C3— 

=  -B(XB- 

-M) 

EDEPTH 

«  DU 

EDEPTH 

EDEPTH 

CALL 

DSMSOL (C3, 3, 3) 

EDEPTH 

EDEPTH 

CALCULATE 

EDEPTH 

DXB 

DXA 

DXA 

EDEPTH 

- = 

—  +  LA— - 

EDEPTH 

DU 

DU 

DU 

EDEPTH 

EDEPTH 

c 

c 

c 

c 

c 

c 

c 

c 


« 

C12 

» 

« 

C22 

« 


DXA 

XA’ A - 

DU 

DXB 

(XB-M) ’B--- 
DU 


C12  =  0.0 
C22  =  0.0 
DO  26  1=1,3 

PXBU(I)  =  PXAU(I)  ♦  XL*{A(I,1)»PXAU(1) 

»  ♦  A ( I ,2) *PXAU(2)  ♦  A(I ,3) *PXAU(3)  ) 

C12  =  C12  +  AXA(I) *PXAU(I) 

26  C22  =  C22  ♦  BXBM(I) «PXBU(I) 


C 

C 

C 

C 

C 


C 

C 

C 

C 


SOLVE  FOB  DL  AMD  DU 
C11*DL  +  C12»DU  =  C13 
C21*DL  ♦  C22«DU  =  C23 


DET  =  C11«C22-C12*C21 
DL  =  (C13*C22-C12*C23)/DET 
DU  =  (C11»C23-C13*C21)/DET 


INCREMENT  L  AND  U 
TEST  FOB  CONVEBQEMCE 


XL  =  XL  +  DL 
XU  =  XU  ♦  DU 

IF  (DABS(DL/XL) .GT.EPSC12) )  GO  TO  11 
IF  (DABS (DU/XU) . GT . EPS ( 12) )  GO  TO  11 
31  CONTINUE 
RETURN 
END 
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EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 

EDEPTH 
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EDEPTH 
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EDEPTH 

EDEPTH 

EDEPTH 
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DOUBLE  PRECISION  FUNCTION  EFUNCT  (TH.THD, SPR, JSTOP) 

REV  20 

COMPUTES  NONLINEAR  SRRINQ  TORQUE  FOR  EULER  JOINTS. 


EFUNCT 

04/29/80EFUNCT 

EFUNCT 


ARGUMENTS : 
TH 
THD 
SPR 
JSTOP 


THETA  IS  THE  ANGLE  OF  THE  EULER  AXIS 
THETA  DOT 

ARRAT  OF  5  VALUES  DESCRIBING  FUNCTION  EVALUATION 
INDICATOR  TO  BE  SET  TO  ONE  IF  IN  STOP 


IMPLICIT  REAL*8 (A-H.O-Z) 

DIMENSION  SPR (5) 

JSTOP  =  0 
EFUNCT  =  TH»SPR( 1) 

TEN  =  10.0 

Q  =  DSIGN(TEN*THD,TH«THD) 

IF  (Q.GT.1.0)  Q  =  1.0 

IF  (Q.LT.-l.O)  Q  =  -1.0 

X  =  0 . 5* ( 1 . 0+SPR(4) *Q« ( 1 . 0-SPR14) ) ) 

IF  (SPR(5) -GT.O.O)  GO  TO  10 
EFUNCT  =  X* EFUNCT 
GO  TO  99 

10  IF  (DABS(TH) . LT.SPR(5))  GO  TO  99 
JSTOP  =  1 

Z  =  DABS (TH)  -  SPR!*) 

EFUNCT  =  EFUNCT  ♦  DSIGN(X» (SPR(2) +Z»SPR(3) ) »Z»»2 ,TH) 
99  RETURN 
END 


EFUNCT 

EFUNCT 

EFUNCT 

EFUNCT 

EFUNCT 

EFUNCT 

EFUNCT 

EFUNCT 

EFUNCT 

EFUNCT 

EFUNCT 

EFUNCT 

EFUNCT 

EFUNCT 

EFUNCT 

EFUNCT 

EFUNCT 

EFUNCT 

EFUNCT 

EFUNCT 

EFUNCT 

EFUNCT 

EFUNCT 

EFUNCT 

EFUNCT 
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SUBROUTINE  EJOINT ( I J ,MK)  JDRIFT 

REV  IV  07/24/86SLIP 

COMPUTES  THE  TORQUES  ACTING  ON  AN  EULER  JOINT  EJOINT 

AND  ADDS  THEM  TO  THE  U2  ARRAY.  EJOINT 

EJOINT 

ARGUMENTS :  EJOINT 

NK  =  0  -  REGULAR  COMPUTATION  FOR  ALL  EULER  JOINTS  JDRIFT 

*  0  -  COMPUTE  ONLY  FOR  JOINT  NJ  IMPULSE  EJOINT 

EJOINT 

IJ  =  1  IMPULSE  ON  PRECESSION  AXIS  ONLY  EJOINT 

=  2  IMPULSE  ON  NUTATION  AXIS  ONLY  EJOINT 

=  3  IMPULSE  ON  SPIN  AXIS  ONLY  EJOINT 

=  4  IMPULSE  ON  GLOBALGRAPHIC  AXIS  EJOINT 

NK  =  0,  IJ  •  0,  SPECIAL  COMPUTATIONS  OF  HIR  AND  HB  ONLY  oDRIFT 

EJOINT 

IMPLICIT  REAL«8(A-H,0-Z)  EJOINT 

COMMON/CONTRL/  TIME, NSEG , NJNT , NPL , NBLT , NBAG , NVEH , NGRND ,  EJOINT 

*  NS , NQ , NSD , NFLX , NHRNSS , NWINDF , NJNTF , NPRT (36) , NPG  PAGE 

COMMON/ SGMNTS/  D(3,3,30) ,WMEG(3,30) ,WMEGD(3,30) ,U1(3,30) ,U2(3,30) .EJOINT 

*  SEGLP(3,30) ,SEGLV(3,30) ,SEGLA(3,30) ,NSYM(30)  EJOINT 

COMMON/ DESCRP/  PHI (3,30) ,W(30) ,RW(30) ,SR(4,60) ,HA(3,60) ,HB(3,60) ,  SLIP 

»  RPHI (3,30) ,HT(3,3,60) ,SPRING(5 ,90) ,VISC(7,90) ,  EJOINT 

«  JNT(30) ,IPIN(30) ,ISING(30) , IGL0B(30) ,J0INTF(30)  EJOINT 

COMMON/ CMATRX/  VK3.30) ,V2(3,30) ,V3(3,I2) ,B12(3,3,60) ,A22(3,3,60) .EJOINT 

*  F(3,30) ,TQ(3,30) ,WJ(30) , All (3,3,30)  SLIP 

COMMON/CEULER/  IEULER(30) ,HIB(3,3,90) ,ANG(3,30) ,ANGD(3,30) ,  JDRIFT 

«  FE (3 , 30 ) ,TQE(3,30) , CONST (5, 30)  JDRIFT 

C0MM0N/F0RCES/PSF(7 ,70) ,BSF(4,20) ,SSF(I0,40) ,BAGSF(3,20) ,  NCFORC 

»  PRJNT(7,30) ,NPANEL(5) , NPSF , NBSF , HSSF , NBGSF  EJOINT 

COMMON/TEMPVI /  CREST ,TTI (3) ,R1I (3) ,R2I (3) , JSTOP (4 ,2 .30)  EJOINT 

COMMON/CNSNTS/  PI .RADIAN, G, THIRD, EPS(24) ,  EJOINT 

«  UNITL.UNITM,UNITT,GRAVTY(3) .TWOPI  TWOPI 

COMMON/TEMPVS/  DH1 (3,3) ,DH4(3,3) ,TH(3,3) ,HIM(3,3) ,HIJ(3,3) ,  EJOINT 

«  HDT(3,3) ,H2(3,3) ,SH(3) ,TM(3) ,TJ(3) ,WMJ(3) ,AD(3) ,  EJOINT 

*  CV (3)  ,CS(3)  , ANGLO)  ,HD3(3)  ,CC(3)  ,T9(3)  ,LSKIP(3)  EJOINT 

LOGICAL  LSKIP  EJOINT 

IF  (NJNT.LE.O)  GO  TO  99  EJOINT 

CALL  ELTIME( 1 ,31)  EJOINT 

J1  =  1  EJOINT 

J2  =  NJNT  EJOINT 

NJ  =  NK  JDRIFT 

IF  (NJ.EQ.O)  GO  TO  11  EJOINT 

J1  =  NJ  EJOINT 

J2  =  NJ  EJOINT 

IF(IJ.LT.O)  NJ  =  0  JDRIFT 

11  DO  98  J=J1 , J2  EJOINT 

IF  (IABS(IPIN(J) ) .NE.4)  GO  TO  98  EJOINT 

M  =  IABS (JNT(J) )  EJOINT 

CALL  D0T33 (D ( 1 , 1 , M) , HT ( 1 , 1 , 2»J- 1 ) , DH1 )  EJOINT 

CALL  D0T33(D(1 , 1 ,J+1) , HT(1 , 1 , 2*J) ,DH4)  EJOINT 


CALL  D0T33 ( DH4 , DH 1 , TH) 

EJOIHT 

DO  12  1=1,3 

EJOIHT 

12  AHG(I.J)  =  AHG(I.J)  +  COHST(I.J) 

EJOIHT 

IC  =  IEULEB(J) 

EJOIHT 

CALL  EULBA D  (TH, AMG(1 , J) , IC) 

EJOIHT 

CALL  BOT (H2 ,3,-AMG(l , J) ) 

EJOIHT 

DO  13  1=1,3 

EJOIHT 

AHG(I.J)  =  AMG(I.J)  -  CONST (I ,J) 

EJOIHT 

HIB(I.l.J)  =  DH1(I,3) 

EJOIHT 

HIB(I ,3, J)  =  DH4 (I ,3) 

EJOIHT 

HIM(I ,  1)  =  HT(1 ,3 ,2*J-1) 

EJOIHT 

HIJ (1,3)  =  HT(I,3,2»J) 

EJOIHT 

LSKIP(I)  =  .FALSE. 

EJOIHT 

FE(I , J)  =  0.0 

EJOIHT 

CV(I)  =  0.0 

EJOIHT 

CS ( I )  =  0.0 

EJOIHT 

V2 (I , J)  =  0.0 

EJOIHT 

TQE(I,J)  =  0.0 

EJOIHT 

13  TQ(I , J)  =  0.0 

EJOIHT 

WJ(J)  =0.0 

EJOIHT 

TQC  =  0.0 

EJOIHT 

IF  (IJ.EQ.4)  GO  TO  55 

EJOIHT 

CALL  MAT31  (HT( 1 , 1 ,2*J-1) , H2 (1,1) , HIM ( 1,2)) 

EJOIHT 

CALL  MAT31  (HT(1 . 1 , 2* J- 1 )  ,H2(1 ,2)  .HIMd  ,3) ) 

EJOIHT 

CALL  D0T31  (D(l ,  1 ,11)  ,HIM(1 ,2)  ,H2(1 ,2) ) 

EJOIHT 

CALL  DOT31  (D(  1 , 1  ,M)  .HIMd  ,3)  ,H2(  1 ,3) ) 

EJOIHT 

CALL  CBOSS  (H2 ( 1 ,2) , HIB( 1 ,3 , J) , H2 (1,1)) 

EJOIHT 

CALL  DOT31  (D ( 1 , 1 ,M  ) . WMEG ( 1 , M  ) ,TM) 

EJOIHT 

CALL  DOT31  (D ( 1 . 1 , J+ 1) , WMEG( l , J+ 1) ,TJ) 

EJOIHT 

SWJ  =  0.0 

EJOIHT 

DO  14  1=1,3 

EJOIHT 

HIB(I , 2 , J)  =  H2 (I , 2) 

EJOIHT 

WMJ(I)  =  TJ(I)  -  TM(I) 

EJOIHT 

14  SWJ  =  SWJ  ♦  WMJ (I) »*2 

EJOIHT 

WJ(J)  =  DSQBT(SWJ) 

EJOIHT 

CALL  DOT31  (HIB( 1 , 1 , J) , WMJ ,AD) 

EJOIHT 

CALL  CBOSS  (TM,HIB(1 , 1 , J) ,HDT(1 , 1) ) 

EJOIHT 

CALL  CBOSS  (TM,HIB( 1 , 2 , J) , HDT (1,2)) 

EJOIHT 

CALL  CBOSS  (TJ,HIB(1 , 3, J) , HDT(1 ,3) ) 

EJOIHT 

CALL  MAT31  (D ( 1 , 1 , J+l) , HIB( 1 , 1 , J) ,HIJ (1 , 1) ) 

EJOIHT 

CALL  MAT31  (D( 1 , 1 , J+ 1) ,HIB( 1 , 2 , J) ,HIJ (1,2)) 

EJOIHT 

CALL  MAT31  ( D ( 1 , 1 . M  ) ,HIB(1 ,3,J) ,HIM(1 ,3) ) 

EJOIHT 

N  =  IEVLER(J) 

EJOIHT 

DO  15  1=1,3 

EJOIHT 

SHd)  =  AD(I) 

JDBIFT 

DO  15  K=1 ,3 

JDBIFT 

HIB(I ,K,2»J+29)  =  HIM(I,K) 

JDBIFT 

15  HIBd  ,K,2»J+30)  =  HIJ(I.K) 

JDBIFT 

IF  (H.EQ.8)  GO  TO  19 

EJOIHT 

IF  (H.GT.3)  GO  TO  16 

EJOIHT 
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SH(N)  =  0.0  EJOINT 

GO  TO  18  EJOIMT 

16  DO  17  1*1,3  EJOINT 

17  IF  (I.ME.N-3)  SH(I)  =  0.0  EJOINT 

18  IF  (N.NE.2)  GO  TO  21  EJOINT 

19  HX  =  H2 (1 , 1) • HI B ( 1 , 1 , J)  ♦  H2 (2 , 1) *HIR(2 , 1 , J)  +  H2 (3 , 1) «HIR(3 . 1 , J)  EJOINT 

IF  (DABS(HX) . GE.EPS(6) )  GO  TO  20  EJOINT 

SH( 1)  =  ANGD(l.J)  EJOINT 

SH(3)  =  ANGD(3 , J)  EJOINT 

GO  TO  21  EJOINT 

20  CALL  D0T31  (H2,WMJ,SH)  EJOINT 

SH( 1)  =  SH(1)/HX  EJOINT 

IF  (N.EQ.2)  SH(2)  =  0.0  EJOINT 

SH(3)  =  SH(3)/HX  EJOINT 

21  DO  22  1=1,3  EJOINT 

ANGD(I.J)  =  SH(I)  EJOINT 

22  HDT (1,2)  =  HDT (1,2)  ♦  SH( 1) *H2 (I , 3)  EJOINT 

IF  (NJ.NE.O)  N  =  IJ*3  EJOINT 

IF  (N.GT.3)  GO  TO  30  EJOINT 

N4  =  4-N  EJOINT 

IF  (N.EQ.2)  AHDT  =  HDT( 1 ,2) *WfcJ ( 1 ) +  HDT (2,2) *WMJ(2) +HDT(3 ,2) »WMJ (3) EJOINT 

IF  (N.NE.2)  AHDT  =  - (SH(2) »HDT( 1 ,2) +SH(N4) »HDT( 1 ,N4) ) *H2  (1 , N)  EJOINT 

»  — ( SH ( 2 ) *HDT (2 , 2) +SH(N4) *HDT (2 ,N4) ) »H2 (2 ,N)  EJOINT 

»  — ( SH ( 2 ) «HDT(3 , 2) *SH(N4) *HDT (3 ,N4) ) *H2 (3 ,N)  EJOINT 

CALL  MAT31  (D(1,1,M  ) ,H2(1 ,N) ,HB(1 ,2*J-1) )  EJOINT 

CALL  MAT31  (D ( 1 , 1 , J+ 1 ) ,H2 ( 1 ,N) ,HB ( 1 , 2«J  ))  EJOINT 

DO  25  1=1,3  EJOINT 

V2 (I , J)  =  AHDT»H2 (I ,N)  EJOINT 

25  IF  (N.EQ.I)  LSKIP(I)  =  . TBUE .  EJOINT 

GO  TO  42  EJOINT 

30  IF  (N.GT.6)  GO  TO  40  EJOINT 

K3J  =  3*J-2  EJOINT 

DO  32  1=1,3  EJOINT 

TF  (NJ.EQ.O)  GO  TO  31  EJOINT 

IF  (I.EQ.N-3)  CREST  =  VISC(7,K3J)  EJOINT 

TQE(I.J)  =  H2(I,N-3)  EJOINT 

GO  TO  32  EJOINT 

31  V2 ( I , J)  =  -HDT (I ,N-3) »AD(N-3)  EJOINT 

HB(I ,2*J-1)  =  HIM(I,N-3)  EJOINT 

HB  ( 1 , 2»J  )  =  HIJU.N-3)  EJOINT 

IF  (I.NE.N-3)  LSKIP(I)  =  .TRUE.  EJOINT 

32  K3J  =  K3J  ♦  1  EJOINT 

IF  (NJ)  35,42,35  EJOINT 

40  IF  (N.EQ.7)  GO  TO  97  EJOINT 

42  IF(IJ.NE.O)  GOTO  98  JDRIFT 

DO  41  1=1,3  JDRIFT 

TF  (LSKIP(I))  GO  TO  41  EJOINT 

K3J  =  3»J-3+I  EJOINT 

CV(I)  =  ANGD(I , J) »VISCOS (DABS (ANGD(I , J) ) , VISC ( 1 ,K3J) , HA (1 , 2  *  J ) )  EJOINT 

CS(I)  =  EFUNCT(ANG(I,J) ,ANGD(I,J) , SPRING( 1 ,K3J) , JSTOP(I . 1 , J) )  EJOINT 


« 


1 


FE(I , J)  =  CS(I)  +  CV(I)  +  HA( I , 2»J) «HA(I , 2*J- 1) 

41  CONTINUE 

CALL  HAT31 ( HI R ( 1 , 1 , J) ,FE(1,J) .TQE(l.J)) 

IF(NJ.GT.O)  GO  TO  34 
55  IF  (IGLOB(J) . EQ.O)  GO  TO  34 
HD3 ( 1 )  =  TH(3 , 1) 

HD3  (2)  =  TH(3 , 2) 

HD3 (3)  =  TH(3 , 3) 

CALL  GLOBAL  (J.HD3.DH1 ,TQC ,T9 , ANGL) 

34  CONTINUE 

ADD  TORQUE  CONVERTED  TO  LOCAL  REFERENCE  TO  U2  ARRAY  BY 
U2(M  )  =  U2(M  )  ♦  D(M  )«TQ 
U2 ( J+ 1 )  =  U2(J+1)  -  D(J*1) *TQ 

35  DO  51  1=1,3 

TQ(I,J)  =  TQE(I , J) +TQC»T9(I) 

TTI ( I )  =  TQ ( I , J) 

DO  51  K= 1 , 3 

U2(K,M  )  =  U2 (K,M  )  +  DIK.I.M  )*TQ(I,J) 

51  U2(K, J+l)  =  U2(K,J+1)  -  D(K, I , J+l) »TQ(I ,J) 


STORE  DATA  INTO  PRJNT  ARRAY  FOR  OUTPUT  ROUTINE 


97  PRJNT ( 1 , J)  =  IEULER(J) 

PRJNT (2 ,J)  =  ANG(l.J) 

PRJNT (3 , J)  =  ANG ( 2 , J ) 

PRJNT (4 ,J)  =  ANG(3 , J) 

PRJNT (5 , J) =CS (1) **2+CS (3) *»2+2. 0*CS ( 1) «CS (3) *TH(3 ,3) +CS (2) »«2 
PRJNT (6 , J) =CV (1) *»2*CV (3) »*2+2.0»CV ( 1) »CV(3) »TH(3 ,3) +CV(2) »»2 
PRJNT (7 , J)  =  TQ (1 , J) «#2  +  TQ(2,J)«»2  +  TQ(3,J)**2 

98  CONTINUE 

CALL  ELTIME(2,31) 

99  RETURN 
END 
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DOUBLE  PRECISION  FUNCTION  ELONG(A,B ,C ,D ,E)  ELONG 

REV  01  10/05/72ELONG 

COMPUTES  ARC  LENGTH  OF  ELLIPSE  AX»«2  +  2BXY  +  CY*«2  =  1  ELONG 

FROM  THETA=0  (POSITIVE  X  AXIS)  TO  THETA=E  (RADIANS)  ELONG 

WHERE  D  IS  NOMINAL  INCREMENT  OF  INTEGRATION.  ELONG 

ELONG 

IMPLICIT  REAL«8 (A-H.O-Z)  ELONG 

N=DABS (E/D)  ELONG 

N=N+N  ELONG 

IF (N. EQ . 0) N=2  ELONG 

Z=N  ELONG 

T=E/Z  ELONG 

F  =  DSQRT  ( ( 1 . + (B/A) »#2) /A)  ELONG 

CS= 1 .  ELONG 

SN=0 .  ELONG 

DCS=DCOS (T)  ELONG 

DSN=DSIN(T)  ELONG 

S=F/2 .  ELONG 

AC  =  A+C  ELONG 

BAC  =  B*B-A«C  ELONG 

DO  10  1=1, N. 2  ELONG 

CSS=CS*DCS-SN«DSN  ELONG 

SN=SN*DCS+CS*DSN  ELONG 

CS=CSS  ELONG 

G= (A*CS+B*SN) »CS  + (B»CS+C*SN) »SN  ELONG 

G  =  G«»2/(AC  +  BAC/G)  ELONG 

F=(F+l./(F*G))/2.  ELONG 

S=S+F+F  ELONG 

CSS=CS*DCS-SN»DSN  ELONG 

SN=SN*DCS+CS»DSN  ELONG 

CS=CSS  ELONG 

G= (A*CS+B«SN) #CS+ (B*CS+C*SN) *SN  ELONG 

G  =  G««2/(AC  +  BAC/G)  ELONG 

F= (F+ 1 . / (F*G) ) / 2 .  ELONG 

S=S+F  ELONG 

10  CONTINUE  ELONG 

ELONG= (S+S-F) *T/3 .  ELONG 

RETURN  ELONG 

END  ELONG 


SUBROUTINE  ELTIME(L.N)  ELTIME 

REV  I I I. 2  08/08/84REVIII 

COUNTS  THE  NUMBER  OF  TIMES  CERTAIN  BASIC  SUBROUTINES  ARE  CALLED  ELTIME 
AND  ACCOUNTS  FOR  ALL  COMPUTER  CPU  TIME  USED  BY  THESE  ROUTINES.  ELTIME 

ELTIME 

ARGUMENTS  L:  1  INDICATES  CALL  IS  AT  START  OF  ROUTINE  ELTIME 

2  INDICATES  CALL  IS  AT  END  OF  ROUTINE.  ELTIME 

>2  PAGE  NUMBER  FOR  CALL  AT  END  OF  RUN  PAGE 

N:  THE  SUBROUTINE  IDENTIFICATION  NUMBER.  ELTIME 

ELTIME 

ASSUMES  FUNCTION  LTIME(l)  IS  GIVING  ELAPSED  CPU  TIME  IN  INTEGER  ELTIME 
UNITS  OF  0.01  SECONDS  SINCE  FUNCTION  LTIME(O)  WAS  CALLED.  ELTIME 

ELTIME 

DIMENSION  NT(40) ,MTIN(40) ,NC(40) ,IND(40)  ELTIME 

REAL *8  SUB (40)  ELTIME 

DATA  SUB/  ELTIME 

*  8H  MAIN3D  ,8H  INPUT  ,8H  DINT  ,8H  PRIPLT  ,8H  DZP  ,  ELTIME 

*  8H  PDAUX  ,8H  UPDATE  ,8H  OUTPUT  ,8H  DAUX  ,8H  SETUP1  ,  ELTIME 

«  8H  CHAIN  ,8H  CONTCT  ,8H  VISPR  ,8H  DAUX11  ,8H  DAUX I 2  .  ELTIME 

*  8H  DAUX22  ,8H  DAUX31  ,8H  DAUX32  ,8H  DAUX33  ,8H  FSMSOL  .  ELTIME 

*  8H  PLELP  ,8H  BELTRT  ,8H  SEGSEG  ,8H  AIRBAG  ,8H  RSTART  .  ELTIME 

*  8H  SETUP2  ,8H  IMPULS  ,8H  IMPLS2  ,8H  AIRBG3  ,BH  DAUX55  ,  ELTIME 

*  8H  EJOINT  ,8H  SPDAMP  ,8H  DAUX44  ,8H  FLXSEG  ,8H  EQUILB  ,  ELTIME 

*  8H  POSTPR  ,8H  WINDY  ,8H  HBELT  ,8H  HPTURB  ,8H  /  ELTIME 

IF  (N.GT.l)  GO  TO  20  ELTIME 

IF  (L.GT.l)  GO  TO  40  ELTIME 

ELTIME 

INITIAL  CALL  AT  BEGINNING  OF  MAIN  PROGRAM.  ELTIME 

ELTIME 

MTIN(l)  =  LTIME(O)  ELTIME 

DO  11  1=1.40  ELTIME 

IND(I)  =  0  ELTIME 

NC ( I )  =  0  ELTIME 

MTIN(I)  =  -1  ELTIME 

11  NT(I)  =  0  ELTIME 

NSUB  =  1  ELTIME 

IND(l)  =  1  ELTIME 

NC ( 1 )  =  1  ELTIME 

MTIN(l)  =  o  ELTIME 

GO  TO  99  ELTIME 

ELTIME 

CALL  AT  BEGINNING  OF  NTH  SUBROUTINE.  ELTIME 

ELTIME 

20  IF  (L.GT.l)  GO  TO  30  ELTIME 

MTIN(N)  =  LTIME(l)  ELTIME 

IF  (NC(N).NE.O)  GO  TO  21  ELTIME 

NSUB  =  NSUB+1  ELTIME 

IND(NSUB)  =  N  ELTIME 

21  NC (N)  =  NC (N) + 1  ELTIME 

GO  TO  99  ELTIME 


$ 


m 


c 

c 

c 


30 


C 

C 

C 


31 

32 


40 


41 


CALL  AT  END  OF  NTH  SUBROUTINE. 

MTOUT  =  LTIME(l) 

NDIFF  =  MTOUT- MTIN(N) 

MTIN(N)  =  -1 

IF  (NDIFF. EQ.O)  00  TO  32 
NT(N)  =  NT(N)  ♦  NDIFF 
DO  31  1=1,40 

IF  (MTIN(I) .NE.-l)  MTIN(I)  =  MTIN(I) 

CONTINUE 

00  TO  99 


♦  NDIFF 


SUBSEQUENT  CALLS  FROM  MAIN  PROGRAM,  PRINT  SUMMARY  TABLE. 

NTSUM  =  LTIME(l) 

NT ( 1 )  =  NTSUM  -  MTIN(l) 

TIME  =  FLOAT (NTSUM)/ 100.0 
WRITE  (6,41)  TIME.L 

FORMAT ( ' 1  ELAPSED  CPU  TIME  =’,F10.2,’  SECONDS' ,85X, ’PAGE ’,15// 


CALLS 


TIME 


42 

43 

44 

99 


*  ’  SUB 

PCSUM  =0.0 
NTSUM  =  0 
DO  42  1=1, NSUB 
J  =  IND(I) 

PC  =  FLOAT (NT ( J) ) /TIME 
PCSUM  =  PCSUM  +  PC 
NTSUM  =  NTSUM  ♦  NT(J) 

WRITE  (6,43)  SUB(J) ,NC(J) ,NT(J) ,PC 
FORMAT (A10, 21 10, FI 0.2) 

WRITE  (6,44)  NTSUM. PCSUM 
FORMAT COTOTAL’  ,  14X,  1 10.F10 . 2) 
RETURN 
END 


’//) 
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SUBROUTINE  EQUILB  (YPR.IYPR)  EQUILB 

REV  IV  02/01/88MISD0T 
EQUILB 

ADJUSTS  INITIAL  INPUT  POSITION  PARAMETERS  SUPPLIED  ON  CARDS  G.2  EQUILB 
AND  G. 3  SUCH  THAT  INITIAL  NORMAL  CONTACT  FORCES  ARE  EQUAL  TO  EQUILB 

EITHER  SUPPLIED  VALUES  OR  THOSE  COMPUTED  BY  CONSTRAINT  FORCES.  EQUILB 

EQUILB 

IMPLICIT  REAL*8(A-H,0-Z)  EQUILB 

DIMENSION  YPR(3 ,30)  ,  IYPB(4,30)  EQUILB 

COMMON/CONTRL/  TIME , NSEG , NJNT , NPL , NBLT , NBAG , NVEH , NGRND ,  EQUILB 

»  NS , NQ , NSD , NFLX , NHRNSS , NWI NDF , NJNTF , NPRT ( 36 ) , NPG  PAGE 

COMMON/ SGMNTS/  D(3,3,30) ,WMEG(3.30) ,WMEGD(3,30) ,U1(3,30) ,U2(3,30) .EQUILB 
»  SEGLP(3,30) ,SEGLV(3,30) ,SEGLA(3,30) ,NSYM(30)  EQUILB 

COMMON/DESCRP/  PHI (3,30) ,W(30) ,RW(30) ,SR(4,60) ,HA(3,60) ,HB(3,60) ,  SLIP 

*  RPHI (3,30) ,HT(3,3,60) .SPRING (5, 90) ,VISC(7,90) ,  EQUILB 

*  JNT(30) ,IPIN(30) ,ISING(30) ,IGLOB(30) ,J0INTF(30)  EQUILB 

COMMON/CMATRX/  VI (3,30) ,V2(3,30) ,V3(3,12) ,B12(3,3,60) ,A22(3,3,60) .EQUILB 

«  F(3 , 30) ,TQ (3 , 30) , WJ (30) , AI 1 (3 , 3 , 30)  SLIP 

COMMON/CSTRNT/  A13(3,3,24) ,A23(3,3,24) ,B31(3,3,24) ,B32(3,3,24) ,  EQUILB 

*  HHT (3 , 3 , 12) , RK 1 ( 3 , 1 2 ) ,RK2(3,I2) ,QQ(3,12) ,TQQ(3,12) .EQUILB 

*  RQQ(3, 12) ,HQQ(3,12) ,SQQ(12) ,CFQQ(12) ,  EQUILB 

*  KQ1(12) ,KQ2(12) ,KQTYPE(12)  EQUILB 

COMMON/TABLES/MXNTI , MXNTB , MXTB 1 , MXTB2 ,NTI (50) , NTAB ( 1 250 ) , TAB ( 4500) DIMENB 
COMMON/ JBARTZ/  MNPL(  30) ,MNBLT(  8) ,MNSEG(  30) ,MNBAG(  6) ,  EQUILB 

*  MPL(3,5,30) , MBLT(3,5,8) , MSEG(3 , 5 , 30) , MBAG(3 , 10,6) ,  EQUILB 

«  NTPL(  5,30) ,NTBLT(  5,8),NTSEG(  5,30)  EQUILB 

COMMON/CNTSRF/  PL(24,30) ,BELT(20,8) ,TPTS(6,8) ,BD(24,40)  EDGE 

COMMON/CNSNTS/  PI .RADIAN, G.THIRD.EPS (24) ,  EQUILB 

*  UNITL , UNITM.UNITT ,GBAVTY(3) , TWOPI  TWOPI 

COMMON/TITLES/  DATE(3) ,C0MENT(40) ,VPSTTL(20) ,BDYTTL(5) ,  EQUILB 

*  BLTTTL(5,8) ,PLTTL(5,30) ,BAGTTL(5,6) ,SEG(30) ,  EQUILB 

*  J0INT(30) ,CGS(30) , JS(30)  EQUILB 

COMMON/FORCES/PSF (7 ,70) ,BSF(4,20) ,SSF(10,40) ,BAGSF(3,20) ,  EDGE 

*  PRJNT(7,30) ,NPANEL(5) , NPSF , NBSF , NSSF , NBGSF  EDGE 

REAL  DATE , COMENT , VPSTTL , BDYTTL , BLTTTL , PLTTL , BAGTTL , SEG , JO I NT  EQU I LB 

LOGICAL* 1  CGS.JS  EQUILB 

COMMON/TEMP VS/  DMNT(3,3) ,XMN(3) ,XMM(3) ,TM(3) ,RM(3)  EDGE 

DIMENSION  TEMPO)  ,T(5)  ,FX(10)  ,FX1  (10)  EDGE 

DIMENSION  X(10) ,GX(10) ,DX(10) ,DXP(10) ,DPN(5,10)  EQUILB 

DIMENSION  JPL( 10) , JSG( 10) , JX( 10) , Ml (10) ,M2(10) , M3 (10) ,MT(10)  EQUILB 
DIMENSION  NTV (10) ,NI 1 ( 10) , NSG( 10) , NAV (10) ,KSG(5 , 10)  EQUILB 

DIMENSION  ISG(5) ,IPL(5) ,LTYPE(5) ,INDGX(5) ,NTNQ(5)  EQUILB 

DIMENSION  SX(10) ,SGX(10) ,XDEV(10) ,W0RD(2)  EQUILB 

DATA  BLANK/’  ’/  ,  WORD/’  SEGLP’  ,  ’  YPR’ /  EQUILB 

CALL  ELTIME  (1,35)  EQUILB 

EQUILB 

INPUT  CARDS  G. 4 ,  G.5.A-G.5.N,  AND  G.6.A-G.6.M  EQUILB 

EQUILB 

READ  (5,60)  NVAR , NCON  EQUILB 

WRITE  (6,51)  NVAR, NCON, NPG  PAGE 


166 


NPG=NPG+ 1  PAGE 

51  FORMAT (' 1 ’, 5X ,' MVAR  =  ’  ,  13 ,3X, ' NCON  =’,I3,96X,  PAGE 

«  ‘PAGE’ ,15/ 120X,’ CARD  G.4’/)  PAGE 

I CARD  =  4  EQUILB 

JCARD  =  0  EQUILB 

IF  (NVAR.LT. 1  ,OP.  HVAR.GT.IO)  GO  TO  65  EQUILB 

IF  (NCON.LT.O  .OR.  NC0N.GT.5  )  GO  TO  65  EQUILB 

WRITE  (6,52)  EQUILB 

52  FORMAT ('O’ ,4X, ’ J’ ,4X, ’NTV’ ,3X, ’ NI 1 ’ , 3X, ’ NSG’ ,8X, ’GX’ , 12X, ’XDEV* ,  EQUILB 
«7X, ’ JPL’ ,3X, ’ JSG’ , 3X , ’ NAV ’ ,3X, ’KSG(I , J) ,I=1,NAV’ ,23X,’CABDS  G.5'/)EQUILB 

ICARD  =  5  EQUILB 

DO  58  J  =  1 , NVAR  EQUILB 

JCARD  =  J  EQUILB 

READ  (5,53)  NTV(J) ,HI1 (J) ,NSG(J) ,GX(J) ,XDEV(J) .  EQUILB 

»  JPL ( J) , JSG( J) , IAV , (KSG(I , J) , Is 1 , IAV)  EQUILB 

53  FORMAT ( 314, 2F8. 0,814)  EQUILB 

NAV(J)  =  IAV  EQUILB 

WRITE  (6,54)  J,NTV(J) , Mil (J) , NSG(J) , GX(J) , XDEV(J) ,  EQUILB 

*  JPL (J) , JSG( J) , IAV, (KSG(I , J) ,1=1, IAV)  EQUILB 

54  FORMAT (416 ,2F15.6,8I6)  EQUILB 

IF  (NTV(J).LT.l  .OR.  HTV(J).GT.2  )  GO  TO  65  EQUILB 

IF  (MIl(J).LT.l  .OR.  Nil (J) . GT.3  )  GO  TO  65  EQUILB 

IF  (NSG(J).LT.l  .OR.  NSG(J) .GT.NSEG)  GO  TO  65  EQUILB 

IF  (NAV(J).LT.O  .OR.  HAV(J).GT.5  )  GO  TO  65  EQUILB 

IF  (JPL(J).LT.l  .OR.  JPL(J) . GT.HPL  )  GO  TO  65  EQUILB 

IF  (JSG(J).LT.I  .OB.  JSG (J) .GT.NSEG)  GO  TO  65  EQUILB 

K  =  JPL(J)  EQUILB 

NNPL  =  MNPL(K)  EQUILB 

IF  (NNPL.LT.l  .OR.  NNPL.GT.5)  GO  TO  85  EQUILB 

DO  55  1=1, NNPL  EQUILB 

IF  ( JSG(J) . NE . MPL (2 , I ,K) )  GO  TO  55  EQUILB 

JSG(J)  =  I  EQUILB 

GO  TO  56  EQUILB 

55  CONTINUE  EQUILB 

GO  TO  65  EQUILB 

56  IF  (NAV(J) .LE.O)  GO  TO  58  EQUILB 

DO  57  1=1, IAV  EQUILB 

IF  (KSG(I.J) .LT.l  .OR.  KSG(I ,J) .GT.NSEG)  GO  TO  65  EQUILB 

57  CONTINUE  EQUILB 

58  CONTINUE  EQUILB 

IF  (NCON.LE.O)  GO  TO  17  EQUILB 

WRITE  (6,59)  EQUILB 

59  FORMAT (’O’ , 4X, ’ I ’ ,4X, ’ IPL’ , 3X , ’ I SG ’ , 2X , ’ LTYPE ’ , 2X, ’ IMDGX’ ,  EQUILB 

»  87X, ’CARDS  G.6’/)  EQUILB 

ICARD  =  6  EQUILB 

DO  64  1=1, NCON  EQUILB 

JCARD  =  I  EQUILB 

READ  (5,60)  IPL(I) ,ISG(I) ,LTYPE(I) ,INDGX(I)  EQUILB 

WRITE  (6,61)  I , IPL (I) , ISG(I) , LTYPE (I ) , IMDGX(I)  EQUILB 

60  FORMAT (414)  EQUILB 


o  o  o  non 


61  FORMAT (516)  EQUILB 

IF  (  IPL(I) . LT. 1  .OR.  IPL(I) .GT.NPL  )  QO  TO  65  EQUILB 

IF  (  ISG(I).LT.l  .OR.  ISO (I) . QT.NSEG)  GO  TO  65  EQUILB 

IF  (LTYPE(I) .LT.3  .OR.  LTYPE(I) .GT.4  )  GO  TO  65  EQUILB 

IF  (INDGX(I) . LT.O  .OR.  INDGX(I) .GT.HVAR)  GO  TO  65  EQUILB 

J  =  I PL ( I )  EQUILB 

NNPL  =  MNPL(J)  EQUILB 

IF  (NNPL.LT.l  .OR.  NNPL.GT. 5)  GO  TO  65  EQUILB 

DO  62  X=1,NNPL  EQUILB 

IF  (ISG(I) .NE.MPL(2,K, J) )  GO  TO  62  EQUILB 

ISG(I)  =  K  EQUILB 

GO  TO  63  EQUILB 

62  CONTINUE  EQUILB 

GO  TO  65  EQUILB 

63  IF  (INDGX(I) . LE.O)  GO  TO  64  EQUILB 

K  =  INDGX(I)  EQUILB 

IF  (IPL(I) .NE.JPL(K)  .OR.  ISG(I) .NE. JSG(K) )  GO  TO  65  EQUILB 

64  CONTINUE  EQUILB 

GO  TO  17  EQUILB 

EQUILB 

INPUT  ERROR  -  PRINT  MESSAGE  AND  TERMINATE  PROGRAM.  EQUILB 

EQUILB 

65  WRITE  (6,66)  ICARD, JCARD  EQUILB 

66  FORMAT ( ' 0  INPUT  ERROR  OH  CARD  G. ’,12 ’,12 .  EQUILB 

*  PROGRAM  TERMINATED. ’)  EQUILB 

STOP  26  EQUILB 

EQUILB 

DATA  INITIALIZATION.  EQUILB 

EQUILB 

17  NQORG  =  NQ  EQUILB 

DO  19  K= 1 ,NVAR  EQUILB 

J  =  JPL(K)  EQUILB 

I  =  JSG(K)  EQUILB 

Ml (K)  =  MPL(l.I.J)  EQUILB 

M2 (K)  =  MPL(2,I,J)  EQUILB 

M3 (K)  =  MPL (3 , I , J)  EQUILB 

MT(K)  =  NTPL  (I,J)  EQUILB 

JX(K)  =  1  EQUILB 

DXP(K)  =0.0  EQUILB 

II  =  NIHK)  EQUILB 

12  =  NSG(K)  EQUILB 

IF  (NTV(K) .EQ.l)  X(K)  =  SEGLP(I1,I2)  EQUILB 

IF  (NTV(K) .EQ.2)  X(K)  =  YPR(I1,I2)  EQUILB 

SX  (K)  =  X(K)  EQUILB 

SGX(K)  =  GX(K)  EQUILB 

IF  (NAV(K) .LE.O)  GOTO  19  EQUILB 

IAV  =  NAV(K)  EQUILB 

DO  18  L= 1 , IAV  EQUILB 

J2  =  KSG(L.K)  EQUILB 

IF  (NTV(K) .EQ.l)  DPN(L.K)  =  SEGLP(I1,I2)  -  SEGLP(I1,J2)  EQUILB 
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IF  (NTV(K) .EQ.2)  DPN(L.K)  =  YPB(I1.I2)  - 
CONTINUE 

IF  (NPBT(27) .EQ.O)  GO  TO  20 

LET’S  SEE  WHAT  USER  INPUT  LOOKS  LIKE. 

CALL  OUTPUT (0) 

CALL  DAUX(O) 

CALL  PRINT (6H  USER  ) 

CALL  OUTPUT! 1) 

START  FDF  FORCE  ->  CONSTRAINT  FORCE  ITERATION 


PENDOT  =0.0 
DO  50  JITTER= 1 , 10 

ITERATE  INPUT  (X)  SUCH  THAT  F(X)  «  G(X) 

MVAR  =  2 

IF  (NVAR.EQ. 1)  MVAR  =  1 
DO  32  M= 1 . 2 
DO  32  I=MVAR.NVAR 
DO  32  J=1,I 

NITER  =  10 

IF  (DXP(J) .EQ.O.O)  NITER  *  50 
DX(J)  =  0.25 
N1  =  Ml (J) 

N2  =  M2  (J) 

N3  =  M3  (J) 

NP  =  JPL(J) 

NT  =  MT  (J) 

11  =  NI I (J) 

12  =  NSG(J) 

IAV  =  NAV(J) 

IF  (NTV(J) . NE.2)  GO  TO  15 
CALL  DBCIJK  (D , YPR, IYPR.HT , 12) 

IF  (NAV(J) . LE.O)  GO  TO  15 
DO  14  K= 1 , IAV 
J2  =  KSG(K.J) 

CALL  DRCIJK  (D , YPR, IYPR.HT , J2) 

DO  29  ITEB=1, NITER 
CALL  CHAIN (0) 

PEN1  =  PEN 
NPSF  =  1 

CALL  PLELP (N2 , N3 ,N1 , NP , NT) 

PEN  =  PSF<1,1) 

FX1 ( J)  =  FX ( J) 

FXJ  =  0.0 

IF  (PEN. GT. 0.0)  FXJ  =  PSF(2,1) 

IF  (PEN.GT.O.O)  CALL  FRCDFL  ( PEN, PENDOT, NT, 1 , FXJ, ELOSS) 
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FX(J)  =  FXJ 

IF  ( JX( J) -2)  23,21,25 

IF  (FX(J)*FX1(J) .GT.O.O)  GO  TO  22 
IF  (FX1 (J) .EQ.O.O)  JX(J)  =  1 
FX(  J)  =  FX1 (J) 

PEN  =  PEN1 

DX( J)  =  0.5»DX(J) 

X(J)  =  X(J)  -  DX(J) 

GO  TO  27 

F2  =  FX( J)  -  GX( J) 

FI  =  FX1(J)  -  GX(J) 

IF  (Fl*F2.LE.O.O)  GO  TO  24 
IF  (DABS(F2) . LT.DABS(Fl) )  GO  TO  23 
FX(  J)  =  FXKJ) 

DX( J)  =  -DX(J) 

PEN  =  PEN1 

X(J)  =  X(J)  +  2.0«DX(J) 

GO  TO  27 
JX(J)  =  I 

IF  (PEN. GT. 0.0)  JX(J)  =  2 

IF  (ITEB.GT. 1  .AND.  PEN. LT. 0.0  .AND.  PEN. LT. PENl)  GO  TO  26 
X(J)  =  X(J)  ♦  DX(J) 

GO  TO  27 

DXP(J)  =  DX(J) / (FX(J) -FXI (J) ) 

JX(J)  =  3 

IF  (DABS (FX(J) -GX(J) ) .LT.EPS(6) )  GO  TO  30 

IF  (PEN. LT. 0.0)  CALL  FRCDFL  ( -PEN , PENDOT , NT , 1 , FX J , ELOSS ) 

IF  (PEN. LT. 0.0)  FX(J)  =  -FXJ 
X(J)  =  X(J)  -  DXP (J) « (FX( J) -GX(J) ) 

IF  (XDEV(J) . LE.O.O)  GO  TO  42 

IF  (DABS (X(J) -SX( J) ) . LE. XDEV (J) )  GO  TO  42 

WRITE  (6,41)  J,X(J) ,SX(J) ,XDEV(J) 

FORMAT  CO  PROGRAM  IS  BEING  TERMINATED  IN  SUBROUTINE  EQUILB.’// 

»  ’  ITERATION  FOR  VARIABLE  NO. ’,13,’  IS  NOT  CONVERGING. ’ // 

»  ’  VALUE  OF  X  IS  OUT  OF  RANGE.  VALUES  OF  X.SX.XDEV  ARE’// 

*  3G20.8) 

STOP  27 

IF  (NTV(J)  .EQ.  1)  SEGLPdl  ,12)  =  X(J) 

IF  (NTV(J) .EQ.2)  YPR(I 1 ,12)  =X(J) 

IF  (NTV(J) .EQ.2)  CALL  DRCIJX  (D.YPR, IYPR.HT, 12) 

IF  (NAV(J) .LE.O)  GO  TO  29 
DO  28  K= 1 , IAV 
J2  =  KSG(X,J) 

IF  (NTV(J)  .EQ.l)  SEGLPdl, J2)  =  X(J)  -  DPN(K,J) 

IF  (NTV(J)  .EQ.2)  YPRd  1 , J2)  =  X(J)  -  DPN(K.J) 

IF  (NTV(J) .EQ.2)  CALL  DRCIJX  (D.YPR, IYPR,HT,J2) 


IF  (NTV(J)  .EQ.l)  SEGLPdl, J2)  =  X(J)  -  DPN(K,J) 

IF  (NTV(J)  .EQ.2)  YPRd  1 , J2)  =  X(J)  -  DPN(K.J) 

IF  (NTV(J) .EQ.2)  CALL  DRCIJK  (D.YPR, IYPR.HT, J2) 

CONTINUE 

IF  (NPRT(27) .NE.O)  WRITE  (6,31)  M, I , J, ITER.X(J) ,FX(J) 
FORMAT (413 , 4X, 2F12 . 6) 
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IF  (NQ.LE.O)  GO  TO  40 

COMPUTE  VEHICLE  COORDINATES  FOB  FIXED  POINT  CONSTRAINTS. 
DO  35  K=  1 ,  NQ 

IF  (KQTYPE(K) .NE.l)  GO  TO  35 

IF  (KQ2(K) .NE.NVEH)  GO  TO  35 

L  =  KQl(K) 

CALL  DOT31 (D ( 1 , 1 ,L) ,RK1(1,K) ,T) 

DO  34  1=1,3 

TCI)  =  T(I)  +  SEGLP(ItL)  -  SEGLPCI ,NVEH) 

CALL  MAT31 (D( 1 , 1 ,NVEH) , T,RK2 ( 1 ,K) ) 

CONTINUE 

IF  (NPRTC27) . EQ.O)  GO  TO  36 

SOLVE  SYSTEM  EQUATIONS  WITH  CONSTRAINTS  OFF. 

CALL  OUTPUT (0) 

CALL  DAUX(O) 

CALL  PRINT (6HEQUIL2) 

CALL  OUTPUT ( 1 ) 

SET  UP  CONSTRAINTS  TO  PRODUCE  ZERO  ACCELERATIONS. 

NQ  =  NQORG 

IF  (NCON.LE.O)  GO  TO  01 
DO  37  1=1 ,NCON 

NQ  =  NQ+1 
J  =  I PL ( I ) 

K  =  ISG(I) 

NT  =  NTPLCK, J) 

NTNQ(I)  =  NTAB(NT+1) 

NTAB (NT+ 1 )  =  -NQ 
KQ1 (NQ)  =  MPL(2,K,J) 

KQ2  (NQ)  =  MPLd.K.J) 

KQTYPE(NQ)  =  LTYPE(I) 

SOLVE  SYSTEM  EQUATIONS  WITH  CONSTRAINTS  ON. 

CALL  OUTPUT (0) 

CALL  DAUX(O) 

IF  (NPRT(27) .NE.O. AND. JITTER. EQ.l)  CALL  PRINT (6HEQUIL1) 

FETCH  CONSTRAINTS  FORCES  NORMAL  TO  PLANE  SURFACES. 

STORE  FRICTION  FORCE  AND  TURN  OFF  CONSTRAINTS. 

CONV  =  1.0 
DO  39  1=1, NCON 

MQ  =  NQORG* I 
J  =  I  PL (I) 
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K  =  ISQ(I)  EQUILB 

NT  =  NTPL(K.J)  EQUILB 

NTAB(NTU)  =  NTNQ(I)  EQUILB 

M  =  MPL (2 ,K , J)  EQUILB 

N  =  MPL(l.K.J)  EQUILB 

CALL  DOTS! (D(l. 1.1) ,PL(1,J) .TEMP)  EQUILB 

T(I)  *  TEMP ( 1 )  *QQ ( 1 , HQ)  ♦  TEMP (2)  »QQ(2  ,MQ)  ♦  TEMPO)  «QQ(3,MQ)  EQUILB 

II  =  INDGX(I)  EQUILB 

IF  (Il.GT.O  .AND.  DABS (GX(I 1) +T(I) ) . GT.EPS(2) )  CONV  =  0.0  EQUILB 

IF  (Il.GT.O)  GX(I1)  =  0 . 5« (GX(I 1) -T(I) )  EQUILB 

DO  38  L=1 ,3  EQUILB 

38  TEMP(L)  =  QQ(L,MQ)  -  T(I)«TEMP(L)  EQUILB 

LT  =  NTAB(NT)  EQUILB 

39  CALL  MAT3KDU.1.M)  ,TEMP,TAB(LT+19) )  EQUILB 

NQ  =  NQOBG  EQUILB 

IF  (CONV. EQ. 1.0)  GO  TO  81  EQUILB 

50  CONTINUE  EQUILB 

C  EQUILB 

C  PRINT  INPUT  AND  CHANGES  MADE.  EQUILB 

C  EQUILB 

81  IF  (NJNT.LE.O)  GO  TO  86  EQUILB 

CALL  OUTPUT (0)  EQUILB 

CALL  DAUX(O)  EQUILB 

IPRINT  =  0  EQUILB 

DO  84  J=  1 , NJNT  EQUILB 

IF  (IPIN(J) .GE.O)  GO  TO  84  EQUILB 

IF  (VISC (4 , 3»J-2) .GT.O.O)  GO  TO  84  EQUILB 

IF  (IPIN(J) .EQ.-l)  T1  =  DABS (XDY(HB( 1 ,  2*J) , D ( 1 , 1 , J+ 1 ) ,TQ ( 1 , J) ) )  EQUILB 
IF  (IPIN(J) .LE.-2)  T1  =  DSQBT(TQ( 1 , J) *»2+TQ(2 , J) *»2+TQ (3 , J) *»2)  EQUILB 
VISC(4,3*J-2)  =  1 . 5*T1  EQUILB 

IF  ( IPRINT. EQ.O)  WRITE  (6,82)  EQUILB 

82  FORMAT  CO  THE  FOLLOWING  VALUES  FOR  THE  MAX  TORQUE  FOB  A  LOCKED  JOEQUILB 

•  INT  ON  CARDS  B.5  HAVE  BEEN  SET  UP  BY  SUBROUTINE  EQUILB: ’ //  EQUILB 

»  ’  J  SYM  IPIN  T1=VISC (4) ’  /)  EQUILB 

IPRINT  =  1  EQUILB 

WRITE  (6,83)  J.JOINT(J) ,IPIN(J) , VISC(4 ,3*J-2)  EQUILB 

83  FORMAT (I6,1X,A4,I6,F15.6)  EQUILB 

84  CONTINUE  EQUILB 

86  IF  (NQ.LE.O)  GO  TO  91  EQUILB 

IPRINT  =  0  EQUILB 

DO  89  K= 1 ,NQ  EQUILB 

IF  (KQTYPE(K) .NE.l)  GO  TO  89  EQUILB 

IF  (KQ2(K) .NE.NVEH)  GO  TO  89  EQUILB 

IF  (IPRINT. EQ.O)  WRITE  (6,8?)  EQUILB 

87  FORMAT (’0  THE  FOLLOWING  VALUES  FOR  BK2  ON  CARDS  D.6  FOR  FIXED  POIEQUILB 

•NT  CONSTRAINTS  HAVE  BEEN  CHANGED  BY  SUBROUTINE  EQUILB:’//  EQUILB 

«  5X, ’K' ,3X, ’KQTYPE’ ,4X, ’KQ1’ ,5X, ’KQ2’ ,8X, ’ RK2(X) ' ,  EQUILB 

*  9X, ’RK2(Y) ’ ,9X, ’RK2(Z) '/)  EQUILB 

IPRINT  =  1  EQUILB 

WRITE  (6,88)  K, KQTYPE (K) ,KQ1 (K) , KQ2 (K) , (RK2 (I ,K) ,1=1,3)  EQUILB 


K 


3 


FORMAT (16, 318, 3F15. 6) 

CONTINUE 
WRITE  (6  92) 

FORMAT (’0*  THE  FOLLOWING  VARIABLES  ON  CAROS  G.2  AND  G.3 
»  'HAVE  BEEN  CHANGED  BY  SUBROUTINE  EQUILB: '//) 

DO  95  J= 1 , NVAR 

10  =  NTV(J) 

11  =  NI 1 (J) 

12  =  NSG(J) 

WRITE  (6,93)  WORD(IO) ,11,12, SX(J) ,X(J) .BLANK, J,SGX(J) ,GX(J) 
FORMAT (4X, A6 , ’ ( ’ , 12 , * , * , 12 , ' )  FROM’ .F12.6, *  T0\F12.6, 

»  A4 , ’ AND  GX ( ’ , I 2 , ’ }  FROM’ ,F12.6, ’  T0’,F12.6) 

IF  (NAV(J) .LE.O)  GO  TO  95 
IAV  =  NAV(J) 

DO  94  1=1, IAV 

J2  =  KSG(I,J) 

ZSX  =  SX(J)  -  DPN(I.J) 

ZXX  =  X(J)  -  DPN(I,J) 

WRITE  (6,93)  WORD (10) , II ,J2 , ZSX, ZXX 
CONTINUE 

CALL  ELTIME  (2,35) 

RETURN 

END 
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SUBROUTINE  EULRAD(D.A.IC)  EULRAD 

REV  IV  07/23/86TW0PI 

COMPUTES  EULER  ANGLES  PRECESSION,  NUTATION,  AND  SPIN  IN  RADIANS  EULRAD 
AND  PLACES  THEM  INTO  THE  A  ARRAY  FOR  GIVEN  DIRECTION  COSINE  MATR1XEGLRAD 

EULRAD 

ASSUMES  D  *  D(S)D(N)D(P)  .  WHERE  EULRAD 


D(N) =  0 


0  0 
CN  SN 


0  -SN  CN 


CP  SP  0 
D(P) =-SP  CP  0 
0  0  1 


ASSUMES  D  *  D(S)D(N)D(P)  .  WHERE  EULRAD 

EULRAD 

CS  SS  0  100  CP  SP  0  EULRAD 

D (S) =-SS  CS  0  ,  D(N) =  0  CN  SN  ,  D(P)=-SP  CP  0  EULRAD 

001  0  -SN  CN  001  EULRAD 

EULRAD 

AND  P=A( I) ,  N=A(2) ,  S=A(3)  EULRAD 

EULRAO 

ROUTINE  WILL  ALWAYS  WORK  IN  THE  MEMORY  MODE,  I.E.,  WILL  PRODUCE  A  EULRAD 
NEW  SET  OF  A’S  THAT  DIFFER  THE  LEAST  FROM  THE  INPUTTED  A  ARRAY.  EULRAD 
TO  USE  IN  NON-MEMORY  MODE, SET  ALL  A’S  TO  ZERO,  CALL  WITH  IC  =  8.  EULRAD 


AND  P=A( I) ,  N=A(2) .  S=A(3) 


NEW  N  IS  ALWAYS  COMPUTED. 


EULRAD 

EULRAD 

EULRAD 

EULRAD 


IF  N  OR  PI-N  <  10«»-6,  IC  IS  USED  TO  RESOLVE  AMBIGUITES  ON  P  &  S,  EULRAD 


EXCEPT  FOR  IC  =  2  OR  8  WHERE  THEY  ARE  NOT  CHANGED. 

IMPLICIT  REAL*8 (A-H,0-Z) 

DIMENSION  A ( 3) , D ( 3 , 3 ) ,T(6) 

COMMON/CNSNTS/  PI .RADIAN, G, THIRD. EPS(24) , 

*  UNITL,UNITM,UNITT,GRAVTY(3) .TWOPI 

IF  ( D ( 3 , 3 ) . GT .  1.0)  D(3 ,3)  =  1.0 

IF  (D (3 ,3) .LT.-l.O)  D(3 .3)  =  -1.0 

B  =  DAC0S(D(3 ,3) ) 

T  (2)  =  B-A(2) 

T  (5)  =  -B-A(2) 

Z  =  0.0 

IF  (  B.LT.EPS (6) )  Z  =  1.0 

IF  (PI-B.LT.EPS(6) )  Z  =  -1.0 
IF  (Z.NE.O.O)  GO  TO  11 
T ( 1 )  =  DATAN2 (D (3 , 1 ) , -D(3 , 2) )  -  A ( 1 ) 

T (4)  =  T ( 1 )  ♦  PI 

T (3)  =  DATAN2 (D ( 1,3),  D(2,3))  -  A(3) 

T (6)  =  T (3)  ♦  PI 
GO  TO  26 

T ( 1 )  =  DATAN2(D( 1,2) -Z*D(2 , 1)  ,  D ( 1 , 1 ) +Z»D(2 ,2) )  -  A(l)  -  Z*A(3) 
T  (3)  =  T  ( 1 ) 

GO  TO  (21,22,23,23,22.21,22,22)  ,  IC 

SET  T ( 1 )  =  0  EXCEPT  FOR  IC=3,4 
SET  T (3)  =  0  EXCEPT  FOR  IC=1,6 

T  ( 1 )  =  0.0 
GO  TO  25 
T ( 1 )  =  0.0 
T (3)  =  0.0 


EULRAD 

EULRAD 

EULRAD 

EULRAD 

EULRAD 

TWOPI 

EULRAD 

EULRAD 

EULRAD 

EULRAD 

EULRAD 

EULRAD 

EULRAD 

EULRAD 

EULRAD 

EULRAD 

EULRAD 

EULRAD 

EULRAD 

EULRAD 

EULRAD 

EULRAD 

EULRAD 

EULRAD 

EULRAD 

EULRAD 

EULRAD 

EULRAD 

EULRAD 

EULRAD 

EULRAD 


i 


25 

T  (4)  =  T  ( 1) 

EULRAD 

T  (6)  =  T (3) 

EULRAD 

26 

TMAX  =0.0 

EULRAD 

J  =3 

EULRAD 

DO  30  1=1,6 

EULRAD 

T ( I )  =  DMOD(T(I) .TWOPI) 

EULRAD 

IF  (DABS(T(I) ) .GT.PI  ) 

T(I)  =  T(I)  -  DSIGN (TWOPI ,T (I) ) 

EULRAD 

IF  (DABS (TCI) ) . LT.TMAX) 

GO  TO  30 

EULRAD 

TMAX  =  DABS(T(I)) 

EULRAD 

IF  (I.GT.3)  J  =  0 

EULRAD 

30 

CONTINUE 

EULRAD 

IF  (Z.LT.O.O)  T( J+3)  = 

-T(J+3) 

EULRAD 

DO  40  1=1,3 

EULRAD 

IJ  =  I+J 

EULRAD 

40 

A(I)  =  Ad)  +  T(IJ) 

EULRAD 

RETURN 

EULRAD 

END 

EULRAD 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 


DOUBLE  PRECISION  FUNCTION  EVALFD  (D,N,L)  EVALFD 

REV  IV  07/23/86JTF786 

EVALUATE  FUNCTION  THAT  IS  DEFINED  AT  LOCATION  N  OF  TAB  ARRAY  EVALFD 

FOR  ABSCISSA  VALUE  D.  EVALUATES  DERIVATIVE,  FUNCTION  OR  INTEGRAL  EVALFD 
AS  L  EQUALS  0,  1,  OR  2.  TAB  ARRAY  IS  DEFINED  AS  FOLLOWS:  EVALFD 

TAB(N)  -  DO  (NO  RESTRICTIONS  ON  DO)  JTF786 

TAB(N+1)  -  D1  (FI  DEFINED  FOR  DO  <  D  <  !D1!)  JTF786 

TAB(N+2)  -  D2  (F2  DEFINED  FOR  iDli  <  D  <  !D2!)  JTF786 

TAB(N+3)  -  (NOT  CURRENTLY  USED)  EVALFD 

TAB(N+4)  -  (NOT  CURRENTLY  USED)  EVALFD 

TAB(N+5)  -  START  OF  DEFINITION  OF  1ST  PART  OF  FUNCTION  (FI)  EVALFD 

WHICH  IS  FOLLOWED  BY  DEFINITION  OF  2ND  PART  OF  FUNCTION  (F2) ,  EVALFD 

IF  ANY.  EVALFD 

2ND  PART  OF  FUNCTION  EXISTS  IF  D2  IS  NON-ZERO.  EVALFD 

SIGN  OF  D1  DETERMINES  FORM  OF  DEFINITION  FOR  1ST  PART  OF  EVALFD 

THE  FUNCTION.  EVALFD 

EVALFD 

D1  ZERO  INDICATES  THAT  FUNCTION  IS  CONSTANT  D2  FOR  ALL  D.  EVALFD 

EVALFD 

D1  POSITIVE  INDICATES  THAT  TAB(N+5) -TAB(N+10)  CONTAINS  EVALFD 

A0.A1....A5.  THE  COEFFICIENTS  OF  A  5TH  ORDER  POLYNOMIAL. EVALFD 

EVALFD 

D1  NEGATIVE  INDICATES  THAT  TAB(N+5)  CONTAINS  NP  (REAL)  EVALFD 

FOLLOWED  BY  D(l),  F(l),  D(2) ,  F(2)  ....  D(NP) ,  F(NP)  EVALFD 

EVALFD 


WARNING-  TABULAR  FUNCTION  MUST  BE  DEFINED  FOR  WHOLE  RANGE, EVALFD 
THAT  IS,  FROM  DO  TO  D1  INCLUSIVE, OR  D1  TO  D2  INCLUSIVE.  EVALFD 

EVALFD 

EVALFD 

SIMILARLY,  THE  SIGN  OF  D2  (IF  NON-ZERO)  DETERMINES  FORM  OF  EVALFD 
DEFINITION  OF  2ND  PART  OF  FUNCTION,  IF  ANY.  EVALFD 

EVALFD 

EVALFD 


sa 

'•Sal 


IF  D  <  DO  AND  Dl*  0,  DERIVATIVE  =  0  OR  FUNCTION  =  FI (DO)  JTF786 

IF  D  >  ! Dl !  AND  D2=0,  DERIVATIVE  =  0  OR  FUNCTION  =  Fl(!Dli)  JTF786 

IF  D  >  !D2!  AND  D2*0 ,  DERIVATIVE  =  0  OR  FUNCTION  =  F2CD2!)  JTF786 

EVALFD 

NOTE:  PREVIOUS  VERSIONS  ASSUMED  THAT  DO  WAS  NON-NEGATIVE  AND  JTF786 

THAT  F  =  0  FOR  D  <  DO.  JTF786 

JTF786 

IMPLICIT  REAL»8 (A-H ,0-Z)  EVALFD 

COMMON/TABLES/MXNTI , MXNTB , MXTB1 , MXTB2 ,NTI (50) , NTAB ( 1250) , TAB (4500) EVALFD 
F  =  0.0  EVALFD 

IOUTR  =  0  EVALFD 

DO  =  TAB(N)  EVALFD 

Dl  =  TAB (N+ 1 )  EVALFD 

D2  =  TAB (N+2)  EVALFD 

IF  (Dl.NE.O.O)  GO  TO  26  EVALFD 

IF  (L-l)  40,24,25  JTF786 

F  =  D2  EVALFD 


y. 


GO  TO  40 

25  F=  (D-DO) *D2 
GO  TO  40 

C 

C  COMPUTE  INDEX  OF  FI  DEFINITION 

C 

26  NP  =  N+5 

IF  (L.EQ.2)  GO  TO  41 
C 

C  DERIVATIVES  AND  FUNCTIONS  HERE 

C 

IF  (D.GE.DO)  GOTO  22 


EVALFD 

EVALFD 

EVALFD 

EVALFD 

EVALFD 

EVALFD 

EVALFD 

EVALFD 

EVALFD 

INTEGRALS  HAVE  OTHER  LOGIC  EVALFD 

EVALFD 
JTF786 
JTF786 
JTF786 
JTF786 
JTF786 
JTF786 
JTF786 
JTF786 
JTF786 
EVALFD 
EVALFD 
EVALFD 
EVALFD 
EVALFD 
EVALFD 
EVALFD 
EVALFD 
EVALFD 
EVALFD 
EVALFD 
EVALFD 
EVALFD 
EVALFD 
EVALFD 
EVALFD 
EVALFD 
EVALFD 
EVALFD 
EVALFD 
EVALFD 
EVALFD 
EVALFD 
EVALFD 
EVALFD 
EVALFD 
EVALFD 
EVALFD 
EVALFD 
EVALFD 


C  D  <  DO,  RETURN  F=0  FOR  L=0,  OR  F=F1(D0)  FOR  L=l. 

C 

IF  (L.EQ.O)  GOTO  40 
X  =  DO 

IF  (DI.GT.O.O)  GOTO  37 
F  =  TAB (NP+2) 

GOTO  40 

22  IF  (D . LT. DABS (D1 ) )  GOTO  31 
IF  (D2.NE.0.0)  GO  TO  32 
C 

C  D  .GE. ! D I !  ,  D2  =  0 
C 

IF  (Dl.LE.O.O)  GO  TO  33 
C 

C  IOUTR.EQ. 1  INDICATES  D  BEYOND  RANGE.  DERIVATIVE  =  0. 

C  IOUTR.EQ. 0  INDICATES  D.LE.ID1!.  COMPUTE  POLY  DERIVATIVE 

C 

IF  (D.GT.DABS(Dl) )  IOUTR  =  1 
X  =  D1 
GO  TO  37 
C 

C  DO  <  D  <  !D1 ! 

C 

31  IF  (Dl.LT.O.O)  GO  TO  35 
X  =  D 

GO  TO  37 
C 

C  D  .GE.  !D1!,  D2  NON-ZERO,  USE  F2 
C 

32  MP  =  6 
C 

C  COMPUTE  INDEX  OF  F2  DEFINITION 

C 

IF  (Dl.LT.O.O)  MP  =  2.0  •  TAB(NP)+1.0 
NP  =  NP+MP 

IF  (D . LT . DABS (D2) )  GO  TO  34 
IF  (D2.LT.0.0)  GO  TO  33 
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C  EVALFD 

C  IOUTR.EQ.l  INDICATES  D  BEYOND  RANGE.  DERIVATIVE  =  0.  EVALFD 

C  IOUTR.EQ.O  INDICATES  D.LE.!D2!.  COMPUTE  POLY  DERIVATIVE  EVALFD 

C  EVALFD 

IF  (D.GT.DABS(D2) )  IOUTR  =  1  EVALFD 

C  EVALFD 

C  D  .GE.  D2  (POSITIVE).  EVALUATE  F2  FOR  D2  EVALFD 

C  EVALFD 

X  =  D2  EVALFD 

GO  TO  37  EVALFD 

C  EVALFD 

C  D  EXCEEDS  TABULAR  DEFINITION,  SET  F  =  F(NP)  EVALFD 

C  IF  TABLE  DEFINITION  EXTENDS  BEYOND  RANGE,  USE  TABLE  VALUES  EVALFD 

C  EVALFD 

33  MB  =  TAB (NP)  EVALFD 

NB  =  NP+MB+MB  EVALFD 

IF  (D  .LE.  TAB(NB-l) )  GO  TO  35  EVALFD 

IF  (L.EQ.l)  F=TAB (NB)  EVALFD 

GO  TO  40  EVALFD 

C  EVALFD 

C  !D1!  .LE.  D  <  !D2!  EVALFD 

C  EVALFD 

34  IF  (D2.LT.0.0)  GO  TO  35  EVALFD 

X  =  D  EVALFD 

GO  TO  37  EVALFD 

C  EVALFD 

C  EVALUATE  F  FROM  TABULAR  DEFINITION  EVALFD 

C  EVALFD 

35  MB  =  TAB (NP)  EVALFD 

K 1  =  NP+3  EVALFD 

K2  =  NP+MB+MB  EVALFD 

DO  36  K=K1,K2,2  EVALFD 

IF  (D.GT.TAB(K) )  GO  TO  36  EVALFD 

IF  (L-l)  28,27,40  EVALFD 

C  EVALFD 

C  EVALUATE  DERIVATIVE  FROM  TABLE  EVALFD 

C  EVALFD 

28  F  =  (TAB (K+ I ) -TAB (K- 1 ) ) / (TAB (K) -TAB (K-2) )  EVALFD 

GO  TO  40  EVALFD 

C  EVALFD 

C  EVALUATE  FUNCTION  FROM  TABLE  EVALFD 

C  EVALFD 

27  R2  =  TAB (K) -TAB (K-2)  EVALFD 

R1  =  (D-TAB (K-2) ) /R2  EVALFD 

R2  =  (TAB (K) -D  ) /R2  EVALFD 

F  =  R1»TAB(K+1) +R2*TAB(K-1)  EVALFD 

GO  TO  40  EVALFD 

36  CONTINUE  EVALFD 

IF  (L.EQ.l)  F  =  TAB (K2)  EVALFD 

GO  TO  40  EVALFD 


37  IF  (IOUTR.EQ. 1  .AND.  L.EQ.O  )  GO  TO  40 
IF  (L-l)  38,39,40 
C 

C  EVALUATE  DERIVATIVE  OF  5TH  DEGREE  POLYNOMIAL 
C 

38  F  =  TAB (NP+ 1 ) +X* (2 . 0*TAB (NP+2) +X# (3 . 0»TAB (NP+3) +X* (4 . 0*TAB (NP+4) ♦ 

*  X*5 . 0»TAB (NP+5) ) ) ) 

GO  TO  40 

EVALUATE  5TH  DEGREE  POLYNOMIAL 

39  F  =  TAB (NP)  +  X# (TAB (NP+1) +X« (TAB (NP+2) 

*  +X» (TAB (NP+3) +X# (TAB (NP+4) +X*TAB (NP+5) ) ) ) ) 

GO  TO  40 

L=2 :  COMPUTE  INTEGRAL  OF  FUNCTION  FROM  DO  TO  D. 

41  IF  (D.EQ.DO)  GO  TO  40 
XO  =  DO 
XI  =  D1 
DO  50  1=1,2 
IF  (XI)  43,49,42 


42  AO 

TAB (NP  ) 

A1 

= 

TAB (NP+ 1 ) /2 . 0 

A2 

= 

TAB (NP+2) /3 . 0 

A3 

= 

TAB(NP+3)/4.0 

A4 

= 

TAB (NP+4) /5 . 0 

A5 

= 

TAB (NP+5) /6.0 

NP 

= 

NP+6 

IF  (X. ‘IE. 0.0)  F=F-X*  (AO+X»  (Al+X# (A2+X»  (A3+X*  (A4+X»A5) ) ) ) ) 

X  =  DMINl(D.Xl) 

IF  (X.NE.O.O)  F=F+X* (AO  +  X* (Al+X* (A2  +  X» (A3+X» (A4+X+A5) ) ) ) ) 

IF(D.LE.Xl)  GO  TO  40 

IF ( I . EQ . 1 . AND . D2 . NE. 0 . 0)  GO  TO  49 

NOTE  -  NP  WAS  UPDATED  NP=NP+6  BEFORE  THIS,  READY  FOR  SECOND  PASS 

F  =  F  +  (D-Xl ) « (TAB (NP-6) +X1* (TAB (NP-5) +X1» (TAB (NP-4) 

*  +X1 » (TAB (NP-3) +X1» (TAB (NP-2) +X1*TAB (NP-1) ) ) ) ) ) 

GO  TO  40 
43  MB  =  TAB (NP) 

K 1  =  NP+3 
K2  =  NP+MB+MB 
NP  =  K2+1 

DL  =  DMIN1 (D, DABS (XI) ) 

DO  44  X-K1.K2.2 

IF  (XO  .GE. TABOO  )  GO  TO  44 

Z1  =  DMAX1 (XO ,TAB (K-2) ) 

Z2  =  DMIN1 (DL , TAB (K) ) 


EVALFD 

EVALFD 

EVALFD 

EVALFD 

EVALFD 

EVALFD 

EVALFD 

EVALFD 

EVALFD 

EVALFD 

EVALFD 

EVALFD 

EVALFD 

EVALFD 

EVALFD 

EVALFD 

EVALFD 

EVALFD 

EVALFD 

EVALFD 

EVALFD 

EVALFD 

EVALFD 

EVALFD 

EVALFD 

EVALFD 

EVALFD 

EVALFD 

EVALFD 

EVALFD 

EVALFD 

EVALFD 

EVALFD 

EVALFD 

EVALFD 

EVALFD 

EVALFD 

EVALFD 

EVALFD 

EVALFD 

EVALFD 

EVALFD 

EVALFD 

EVALFD 

EVALFD 

EVALFD 

EVALFD 

EVALFD 

EVALFD 

EVALFD 


FYX  =  TAB(K-l) »TAB(K)  -  TAB(K+1) »TAB(K-2)  EVALFD 

FY  =  TAB(K+1)  -  TAB(K-l)  EVALFD 

F  =  F  + (FYX  ♦  0 . 5*FY# (Z1+Z2) )  «(Z2-Z1)/  (TAB(K) -TAB(K-2) )  EVALFD 

IF  (Z2.NE.DL)  GO  TO  44  EVALFD 

IF(I .EQ. 1 . AND.D2.NE.0.0)  GO  TO  49  EVALFD 

IF (Z2.  EQ.  D)  GO  TO  40  EVALFD 

F  =  F  + (D-Z2) » (FYX+Z2*FY) /  (TAB(K) -TAB(K-2) )  EVALFD 

GO  TO  40  EVALFD 

44  CONTI HUE  EVALFD 

49  XO  =  DABS (Dl)  EVALFD 

50  XI  =  D2  EVALFD 

40  EVALFD  =  F  EVALFD 

RETURN  EVALFD 

END  EVALFD 


SUBROUTINE  FDINIT  FDINIT 

RET  III. 2  08/08/84REVIII 

REPLACES  CODE  PREVIOUSLY  IN  SUBROUTINES  FINPUT  AND  HINPUT.  FDINIT 

FROM  FIVE  FUNCTION  NUMBERS  IN  NF  ARRAY  FDINIT 

1.  SET  UP  KTITLE  FDINIT 

2.  SET  UP  NrAB  AND  TAB  ARRAYS  FDINIT 

3.  INCREMENT  COUNTERS  MXNTB  AND  MXTB2  FDINIT 

FDINIT 

IMPLICIT  REAL *8  (A-H.O-Z)  FDINIT 

COMMON/ TABLES/ MXNT I ,MXNTB,MXTB1 ,MXTB2 ,NTI (50) ,NTAB(1250) .TAB (4500) DIMENB 
COMMON/TEMPVS/  JTITLE (5 , 5 1 ) ,NF (5) ,MS (3) .KTITLE (31)  FDINIT 

NOTE:  THIS  IS  SHARED  BY  SUBS  CINPUT,  FINPUT,  HINPUT  AND  FDINIT.  FDINIT 
REAL  JTITLE, KTITLE  FDINIT 

J1  =  MXTB2  ♦  1  FDINIT 

NT  =  MXNTB  +  1  FDINIT 

NTAB(NT)  =  JI  FDINIT 

NT  =  NT+1  FDINIT 

DO  56  L= 1 , 5  FDINIT 

NX  =  IABS (NF (L) )  FDINIT 

NTAB(NT)  =  0  FDINIT 

IF  (NX.EQ.O)  GO  TO  56  FDINIT 

NTAB(NT)  =  ISIGN(NTI (NX) , NF ( L ) )  FDINIT 

DO  51  KK  =  1.5  FDINIT 

KJ  =  5*L+KK+ 1  FDINIT 

51  KTITLE (KJ)  =  JTITLE (KK , NX)  FDINIT 

IF  (NTI (NX) .NE.O)  GO  TO  56  FDINIT 

WRITE(6 ,54)  NX  FDINIT 

54  FORMAT  (’-0  FUNCTION  NO.' ,14,'  HAS  NOT  BEEN  DEFINED.  *  ,  FDINIT 

*  ’  PROGRAM  TERMINATED. ')  FDINIT 

STOP  15  FDINIT 

56  NT  =  NT+1  FDINIT 

FDINIT 

INITIALIZE  TAB  ARRAY  TO  ZERO  EXCEPT  FOR  DMAX,  DINER.  FDMAX.  FDINIT 

FDINIT 

J2  =  Jl+29  FDINIT 

DO  57  JJ=J1,J2  FDINIT 

57  TAB ( JJ)  =  0.0  FDINIT 

NX  =  NTAB (NT-5)  FDINIT 

IF  (NX.LE.O)  GO  TO  58  BUTLER1 

TAB(Jl+8)  =  DABS (TAB (NX+ 1) )  FDINIT 

IF  (TAB(NX+2) .NE.O.O)  TAB(Jl+8)  =  DABS (TAB (NX+2) )  FDINIT 

DX  =  TAB(Jl+8)  FDINIT 

TAB(J1+10)  =  EVALFD(DX,NX, 1)  FDINIT 

NX  =  NTAB (NT-4)  FDINIT 

IF  (NX.LE.O)  GO  TO  58  FDINIT 

TAB ( J 1 +9)  =  DABS (TAB (NX+1))  FDINIT 

IF  (TAB (NX+2) .NE.O.O)  TAB(Jl+9)  =  DABS (TAB (NX+2) )  FDINIT 

58  Jl  =  J2+ 1  FDINIT 

MXNTB  =  NT-1  FDINIT 

MXTB2  =  Jl-1  FDINIT 


IF  (MXTB2 . GT . 4500)  WHITE  (6,62)  MXTB2  DIMENB 

62  FORMAT  CO  ERROR  IN  SUBROUTINE  FDINIT ,  SIZE  OF  TAB  ARRAY  =',I8//  FDINIT 

*  ’  PROGRAM  TERMINATED. *)  FDINIT 

IF  (MXNTB.GT. 1250)  WRITE  (6,63)  MXNTB  DIMENB 

63  FORMAT  CO  ERROR  IN  SUBROUTINE  FDINIT.  SIZE  OF  NTAB  ARRAY  =’,I8//  FDINIT 


*  ’  PROGRAM  TERMINATED. ’) 

IF  (MXTB2.GT. 4500. OR. MXNTB.GT. 1250)  STOP  16 

RETURN 

END 


FDINIT 

DIMENB 

FDINIT 

FDINIT 


SUBROUTINE  FINPUT  FINPUT 

REV  IV  02/01/B8MISD0T 

INPUT  CARDS  F.1-F.5  SPECIFYING  THE  ALLOWED  CONTACTS  OF  THE  CRASH  FINPUT 
VICTIM  BODY  SEGMENTS  WITH  VEHICLE  PANELS,  BELTS,  AIRBAGS  AND  OTHERFINPUT 
BODY  SEGMENTS  ALONG  WITH  THE  ASSOCIATED  FUNCTIONS  TO  BE  USED  FOB  FINPUT 
EACH  CONTACT.  FINPUT 

ALSO  SETS  UP  TABLES  TO  CONTROL  TIME  HISTORY  INFORMATION  FOR  FINPUT 

EACH  FUNCTION  FOB  EACH  ALLOWED  CONTACT.  FINPUT 

FINPUT 

IMPLICIT  REAL»8(A-H,0-Z)  FINPUT 

COMMON/CONTRL/  T I ME , NSEG , NJNT , NPL , NBLT , NBAG , NVEH , NGRND ,  FINPUT 

»  NS , NQ , NSD , NFLX , NHRNSS , NWI NDF , NJNTF , NPRT ( 36 ) , NPG  PAGE 

COMMON/ DESCRP/  PHI (3,30) ,W(30) ,RW(30) ,SR(4,60) ,HA(3,60) ,HB(3,60) ,  SLIP 

*  RPHI (3,30) ,HT(3 , 3 , 60) , SPRING (5 , 90) , VISC (7 ,90) ,  FINPUT 

*  JNT(30) ,IPIN(30) ,ISINQ(30) ,IGL0B(30) ,J0INTF(30)  FINPUT 

COMMON/ JBARTZ/  MNPL (  30) ,MNBLT(  8) ,MNSEG(  30) ,MNBAG(  6),  FINPUT 

«  MPL(3,5,30) ,MBLT(3,5,8) ,MSEG(3 . 5 ,30) ,MBAG(3, 10,6) ,  FINPUT 

»  NTPL (  5,30) ,NTBLT(  5,8).NTSEG(  5,30)  FINPUT 

COMMON/ TABLES /MXNT I . MXNTB , MXTB 1 , MXTB2 , NTI (50) , NTAB ( 1 250) , TAB (4500)  DIMENB 
COMMON/TITLES/  DATE(3) ,C0MENT(40) ,VPSTTL(20) ,BDYTTL(5) ,  FINPUT 

*  BLTTTL(5,8) ,PLTTL(5,30) ,BAGTTL(5,8) ,SEG(30) ,  FINPUT 

*  J0INT(30) ,CGS(30) ,JS(30)  FINPUT 

REAL  DATE, COMENT , VPSTTL , BDYTTL , BLTTTL , PLTTL , BAGTTL , SEG , JOINT  FINPUT 

LOGICAL* 1  CGS.JS  FINPUT 

COMMON/ CSTRNT/  A13(3,3,24) ,A23(3,3,24) ,B31 (3,3,24) ,B32(3,3,24) ,  FINPUT 

*  HHT(3,3, 12) ,RKI (3, 12) ,SK2(3,I2) ,QQ(3,22) ,TQQ(3,12) .FINPUT 

*  RQQ(3 ,12) ,HQ0(3, 12) ,SQQ(12) , CFQQ(12) ,  FINPUT 

«  KQ1 (12) ,KQ2 (12) ,KQTYPE(12)  FINPUT 

COMMON/ WINDFR/  WTIME  (30)  ,<JFU(3 , 5)  ,QFV(3 , 5)  ,  WF(3 ,30)  ,  IWIND(30)  ,  WINDOP 

*  MWSEG(7,30) ,NFVSEG(6) ,NFVKT(5) ,M0WSEG(30 ,30)  WINDOP 

COMMON/TEMPVS/ JTITLE (5,51) ,NF(5) ,MS(3) ,KTITLE(3I)  FINPUT 

FINPUT 

REAL  JTITLE, KTITLE, BLANK, SURFCE (2, 3)  FINPUT 

DATA  BLANK/4H  /  FINPUT 

DATA  SURFCE/ 4H  PL.4HANE  ,4H  BE.4HLT  ,4H  SEG.4HMENT/  FINPUT 

FINPUT 

MXNT I  =  50  FINPUT 

MXNTB  -  0  FINPUT 

MXTB2  =  MXTB1  FINPUT 

FINPUT 

INPUT  ALLOWED  CONTACTS  AND  FUNCTIONS  BY  REF.  NO.  FINPUT 

FINPUT 

WRITE  (6,31)  NPG  PAGE 

NPG=NPG+ 1  PAGE 

31  FORMAT ( ’ 1  ALLOWED  CONTACTS  AND  ASSOCIATED  FUNCTIONS’ ,80X,  PAGE 

»  ' PAGE ’ , 15)  PAGE 

DO  61  1=1,4  FINPUT 

IJK  =  0  FINPUT 

GOTO  (32,34,35,36) , I  FINPUT 

32  IF  (NPL.LE.O)  GO  TO  61  FINPUT 


mm 


O 


INPUT  NO.  OF  SEGMENTS  TO  CONTACT  EACH  PLANE. 

INPUT  CARD  F.l.A 

READ  (5.33)  (MNPL(J) . J=1 ,NPL) 

33  FORMAT (1814) 

NJJ  =  NPL 
GO  TO  37 

34  IF  (NBLT.LE.O)  GO  TO  61 

INPUT  NO.  OF  SEGMENTS  TO  CONTACT  EACH  BELT. 

INPUT  CARD  F.2.A 

READ  (5,33)  (MNBLT(J) , J= 1 ,NBLT) 

NJJ  =  NBLT 
GO  TO  37 

35  IF  (NSEG.LE.O)  GO  TO  61 

INPUT  NO.  OF  SEGMENTS  TO  CONTACT  EACH  SEGMENT. 

INPUT  CARD  F.3.A 

READ  (5,33)  (MNSEG(J) ,J=1,NSEG) 

NJJ  =  NSEG 
NSEG1  =  NSEG+1 
DO  26  J=NSEG1 , NGRND 
26  MNSEG(J)  =  0 
GO  TO  37 

36  IF  (NJNT.LE.O)  GO  TO  61 
INPUT  CARD  F.4.A 

SUPPLY  I GLOB (J) =1  FOR  EACH  GLOBALGRAPHIC  JOINT  J=1,NJNT 

READ  (5,33)  (IGLOB(J) , J=1 ,NJNT) 

NJJ  =  NJNT 

START  OF  LOOP  TO  READ  CONTACTS  FOR  PLANES  (1=1),  BELTS  (1=2), 
SEGMENTS  (1=3)  AND  FUNCTIONS  FOR  GLOBALGRAPHIC  JOINTS  (1=4). 

37  DO  60  J=1 ,NJJ 

IF  (I.EQ.l)  NK  =  MNPL(J) 

IF  (I.EQ.2)  NK  =  MNBLT(J) 

IF  (I.EQ.3)  NK  =  MNSEG(J) 

IF  (I.EQ.4)  NK  =  I GLOB (J) 

IF  (NK.LE.O)  GO  TO  60 
DO  59  K=1,NK 

IF  (IJK.EQ.O)  WRITE  (8,38)  I 

38  FORMAT (’ O’ ,119X,’ CARDS  F.’.Il) 

IF  (IJK.EQ.O  .AND.  I.NE.4)  WRITE  (6,39)  SURFCE (1,1) , SURFCE (2,1) 

39  FORMAT (’ O’ ,3X,2A4,8X, 'SEGMENT’ ,2X, ’FORCE  DEFLECTION’ ,6X, ’ INERTIAL 
•SPIKE’ , 10X, ’ R  FACTOR’ ,13X, ’G  FACTOR’ , 10X, ’FRICTION  COEF.  OPT’) 


F INPUT 
F INPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
EDGE 


O  O  O  O  O  O  (Si  non 


IF  (IJK.EQ.O  .AMD.  I.EQ.4)  WHITE  (6,40)  FINPUT 

40  FORMAT (’ O’ ,5X, 'JOINT  (GLOBALGRAPHIC) *, 2X, 'TORQUE  DEFLECTION’ ,6X, ’HFIMPOT 
»ERRON  FORMULAMOX, 'R  FACTOR’ ,  13X, ’G  FACTOR’ ,  10X, 'FRICTION  COEF.  ’  JFINPUT 

IJX  =  1  FINPUT 

C  FINPUT 

INPUT  CONTACT  SURFACE  NO.,  SEGMENT  NO. ,  AND  FUNCTION  NOS.  FINPUT 

INPUT  CARD  F. (I) . (K)  FINPUT 

FINPUT 

READ  (5,33)  NJ,MS,NF,NX  EDGE 

WRITE  (6,41)  NJ , MS , NF , NX  EDGE 

41  FORMAT ('0' ,17, ’-’ ,13,111 , ,13,18,4121,112)  EDGE 

IF  (NJ.NE.J)  WRITE  (6,42)  FINPUT 

42  FORMAT ( ’  CONTACT  INPUT  ERROR.  PROGRAM  TERMINATED.’)  FINPUT 

IF  (NJ.NE.J)  STOP  14  FINPUT 

IF  (I . NE. 2 . AfcO.NF (5) . EQ.O)  WRITE(6,20)  MISDOT 

0  FORMAT (’  FRICTION  FUNCTION  NUMBER  CAN  NOT  BE  ZERO  FOR  THIS  TYPE  OFMISDOT 

«  CONTACT’)  MISDOT 

IF  (I.NE.2.AND.NF(5) .EQ.O)  STOP  105  MISDOT 

NLT  =  1  FINPUT 

DO  43  JJ  =  1,31  FINPUT 

43  KTITLE(JJ)  =  BLANK  FINPUT 

GOTO  (44,46,48,49) , I  FINPUT 

FINPUT 


PLACE  SEGMENT  NO.  AND  INDEX  TO  NTAB  ARRAY  INTO  M-  AND  NT-  ARRAYS.  FINPUT 

FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 
FINPUT 


SET  UP  TWO  TABLES  FOR  FULL  BELT  FRICTION 

FINPUT 

FINPUT 

IF  (NF (5) . NE.O)  NLT  =  2 

FINPUT 

GO  TO  50 

FINPUT 

MSEG(1,K,J)  =  MS  ( 1 ) 

FINPUT 

MSEG(2 ,K , J)  =  MS  (2) 

FINPUT 

MSEG(3,X, J)  *  MS (3) 

FINPUT 

NTSEG(K.J)  *  MXNTB+1 

FINPUT 

KTITLE  (3)  =  SEG(J) 

FINPUT 

GO  TO  50 

FINPUT 

FINPUT 

44  MPL(1,K,J)  =  MS(1) 
MPL(2,K,J)  =  MS (2) 
MPL(3,K,J)  =  MS (3) 
NTPL(K.J)  =  MXMTB+1 
DO  45  JJ  =  1,5 

45  KTITLE(JJ)  =  PLTTL  (JJ,J) 
GO  TO  50 

46  MBLT(l.K.J)  =  MS(1) 

MBL?(2 , K, J)  =  MS(2) 

MBLT  ( 3 ,  K ,  J )  =  MS  (3) 
NTBLT(K.J)  =  MXNTB+ 1 
DO  47  JJ  =  1,5 

47  KTITLE (JJ)  =  BLTTTL  (JJ,J) 


NOTE:  QLOBALGBAPHIC  JOINT  KILL  SAVE  NT  IN  IGLOB  ABBAY 


49  IGLOB (J)  =  MXNTB+1 

KTITLE(2)  =  JOINT(J) 


SET  UP  POINTERS  TO  TAB  ABBAY  IN  NTAB  ABBAY. 


50  NFJ  =  MS  (2) 

IF  (NFJ.GT.O)  KTITLE(6)  =  SEG(NFJ) 
DO  51  JJ= 1 ,NLT 

51  CALL  FDINIT 

WRITE  (6.53)  KTITLE 
53  FORMAT ( IX, 5A4 , IX, A4 , 5 ( IX, 5A4) ) 

LT  =  NTAB (MXNTB-5) 

IF  (I.EQ.l)  TAB(LT+22)  =  NX 
IF  (NF ( 1) . HE.O)  GO  TO  59 


IF  FORCE  DEFLECTION  FUNCTION  NO.  IS  ZERO, 
SET  UP  FOR  ROLLING  CONSTRAINT 


NQ  =  NQ+1 

NTAB (MXNTB-4)  =  -NQ 
KQTYPE(NQ)  =  -4 
KQKNQ)  =  MS  (2) 

KQ2 (NQ)  =  MS ( 1 ) 

IF  (I.NE.3)  GO  TO  59 
KQKNQ)  =  J 


KQ2 (NQ)  *  MS (2) 

59  CONTINUE 

60  CONTINUE 

61  CONTINUE 


INPUT  CARD  F.5  -  JOINT  FUNCTIONS  TO  BE  USED. 


IF  (NJNT.LE.O)  GO  TO  81 
IF  (NJNTF.NE.O)  GO  TO  76 
DO  75  J=1 , NJNT 

75  JOINTF(J)  =  0 
GO  TO  81 

76  READ  (5,33)  ( JOINTF (J) , J* 1 ,NJNT) 

IJK  =  0 

DO  80  J= 1 , NJNT 
IF  (JOINTF (J) .EQ.O)  GO  TO  80 
IF  (IJK. EQ.O)  WRITE  (8,77)  NPG 
IF  (IJK. EQ.O)  MPG=NPG+ 1 

77  FORMAT ( ' 1 ’ , 122X, ’PAGE' , I5/120X, 'CARD  F.5’/ 

•  ’  THE  FOLLOWING  JOINT  RESTORING  FORCE  FUNCTIONS  AS 

*0N  CARDS  E. 7  WILL  BE  USED. ' //4X, ’JOINT’.IOX, ’FUNCTION’//) 
JF  =  JOINTF (J) 

IJK  =  1 


F INPUT 

F INPUT 

FINPUT 

F INPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

EDGE 

EDGE 

EDGE 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

EDGE 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

PAGE 

PAGE 

PAGE 

DEFINED  FINPUT 


FINPUT 

FINPUT 

FINPUT 


D 


WRITE  (6.78)  J.JOINT(J)  ,JF,  (JTITLEU  , JF)  ,1  =  1,5) 

78  FORMAT (16, ' - ’ , A4 , 1 10 , ’ - ’ ,5A4) 

IF  (NTI(JF) .EQ.O)  WRITE  (6,42) 

IF  (NTI(JF) .EQ.O)  STOP  17 

80  CONTINUE 

INPOT  CONTACT  SEGMENTS  FOR  AIRBAG,  IF  ANT. 

81  IF  (NBAG.LE.O)  GO  TO  60 
IJK  *  0 

DO  68  J  = 1 , NBAG 
INPUT  CARD  F.6. (J) 

READ  (5,63)  K,NK, (MBAG(2 , I , J) ,MBAG(3 , I , J) ,1=1 ,NK) 

63  FORMAT (214, 2012) 

MNBAG(J)  =  NK 

IF  (NK.EQ.O)  GO  TO  68 
IF  (IJK.EQ.O)  WRITE  (6,64) 

64  F0RMAT(////5X, ’AIRBAG' ,4X, 'VS. ’ .4X, •SEGMENTS’ ,90X, 'CARDS  F.6’) 
IF  (K.NE.J)  WRITE  (6,42) 

IF  (K.NE.J)  STOP  20 

WRITE  (6,65)  J , (MBAG(2 , I , J) , MB AG (3 , I , J) ,1=1 ,NK) 

65  FORMAT ( ’ 0  NO. ’ , 12 , 12X, 10 (13 , ’ - ’,13) ) 

DO  66  1=1, NK 

K  =  MBAG ( 2 , I , J ) 

66  KTITLE(I)  =  SEG(K) 

WRITE  (6,67)  (BAGTTL(I.J) ,1=1,5) , (KTITLE(I) ,1=1, NK) 

67  FORMAT ( IX, 5A4 , 10 (3X , A4) ) 

68  CONTINUE 

INPUT  CARDS  F.7.A-F.7.B  FOR  SUBROUTINE  WINDY. 

69  DO  85  J  = 1 , NGRND 
85  MWSEG(l.J)  =  0 

IF  (NWINDF.EQ.G)  GO  TO  99 

READ  (5,33)  (MWSEG(1 ,J) ,J*1 ,NSEG) 

I PAGE  =  0 
DO  73  J=1,NSEG 
I WIND ( J)  =  0 
WTIME(J)  =  0.0 

IF  (MWSEG(l.J) .EQ.O)  GO  TO  73 
IF  (IPAGE.EQ.O)  WRITE  (6,70)  NPG 
IF  (IPAGE.EQ.O)  NPG=NPG+ 1 

70  FORMAT ( ’ 1  SEGMENT  WIND  FORCES’ , 102X, ’PAGE’ .I5/120X, ’CARDS  F.7’/ 

*  75X, ’DRAG  COEFFICIENT  BLOCKING’/ 

«  ’  SEGMENT -ELL IPSO ID  SEGMENT -PLANE’ , 

»  leX.’WIND  FORCE  FUNCTION’ , 10X, ’FUNCTION’ ,9X, 

*  ’ SEGMENTS-ELLIPSOID’ ) 

I PAGE  =  1 


F INPUT 

F INPUT 

F INPUT 

F INPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINFUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

FINPUT 

PAGE 

PAGE 

PAGE 

WINDOP 

WINDOP 

WINDOP 

WINDOP 

FINPUT 


as 


READ  (5 ,86)  (MWSEGd, J)  ,1  =  1.7)  ,  (MOWSEG(J  ,K)  ,K=1 ,2*MWSEG(7 , J) )  WINDOP 

86  FORMAT  (714,2212/(130,712))  WIHDOP 

WRITE (6 ,71)  (MWSEGd  ,  J)  ,1  =  1,6)  0UT385 

71  FORMAT (1H0, 16, 2H  -,I3,I13,2H  -.13,131,123)  0DT385 

IF  (IABS (MWSEGd  , J) ) . NE.  J)  WRITE  (6,42)  WINDOP 

IF  (IABS (MWSEG( 1 , J) ) .NE.J)  STOP  21  WIHDOP 

M3  =  MWSEG(3 , J)  F INPUT 

M4  =  MWSEG(4 , J)  FINPUT 

M5  =  MWSEG(5 , J)  FINPUT 

M6  =  MWSEG(6,J)  WINDOP 

M7  =  MWSEG(7 , J)  0UT385 

DO  172  11=1,5  FIXWBS 

KTITLEdI)  =BLANK  FIXWBS 

172  IF  (M6.NE.0)  KTITLE(II)=JTITLE(II ,M6)  FIXWBS 

WRITE  (6,72)  SEG(J) ,SEG(M3) , (PLTTL(I ,M4) ,1=1 ,5)  FINPUT 

»  ,  (JTITLE(I,M5)  ,1=1,5)  ,  (KTITLEd)  ,1  =  1,5)  FIXWBS 

»  , (MOWSEG(J.K) ,K=1,2*M7)  0UT385 

72  FORMAT (3X.A4 , 14X, A4 , 1H- , 5A4 , 3X.5A4 ,3X ,5A4 ,2X,3 (5 (13 , 1H- , 13) /94X) )  0UT385 

73  CONTINUE  FINPUT 

99  RETURN  FINPUT 

END  FINPUT 


5SS* 


SUBROUTINE  FLXSEG 


FLXSEG 

C  REV  IV  07/23/86TW0PI 

IMPLICIT  REAL*8 (A-H.O-Z)  FLXSEG 

COMMON/CONTRL/  T I ME , NSEG , NJNT , NPL , NBLT , NBAG , NVEH , NGRND ,  FLXSEG 

*  NS , NQ , NSD , NFLX , NHRNSS , NWI NDF , N JNTF , NPRT ( 36 ) , NPG  PAGE 
COMMON/ SGMNTS/  D (3 ,3,30) ,WMEG(3,30) .WMEGDO.30) ,U1(3,30) ,U2(3,30) .FLXSEG 

»  SEGLP(3,30) ,SEGLV(3,30) ,SEGLA(3,30) ,NSYM(30)  FLXSEG 

COMMON/ FLXBLE/  HF (4 , 12 ,8) , B42 (3 , 3 , 24) , V4 (3 .8) , NFLEX(3 ,8)  FLXSEG 

COMMON/ CNSNTS/  PI .RADIAN, G, THIRD, EPS(24) .  FLXSEG 

*  UNITL,UNITM,UNITT,GRAVTY(3) .TWOPI  TWOPI 

COMMON/ TEMP VS/  TT (3 , 3) .  THN (4) ,  CN1(3,3),  CN(3,3) ,  WNM1 (3) ,  FLXSEG 

»  THND (4) ,  PTD (3) ,  WCSNO)  ,  RHSN(3) ,  RHS1(3),  FLXSEG 

»  RHS  2(3),  GF  (3 , 4)  ,  GC(3,3),  CGC(3,3),  THAO)  ,  FLXSEG 

*  THAD (3)  ,  THADEGO)  ,  DN2NK3.3),  RMGO)  FLXSEG 

DIMENSION  IDYPR (3)  FLXSEG 

DATA  IDYPR/ 3, 2,1/  FLXSEG 

IF  (NFLX.EQ.O)  GO  TO  99  FLXSEG 

CALL  ELTIME<1,34)  FLXSEG 

IFX  =  1  FLXSEG 

11  N1  =  NFLEX(l.IFX)  FLXSEG 

N3  =  NFLEXO  ,  IFX)  FLXSEG 

CALL  DOTT33 (D ( 1,1, N3)  ,  D ( 1 , 1 ,N1 )  ,TT)  FLXSEG 

THN(l)  =  DATAN2 ( TT ( 1 , 2 ) , TT (1.1))  FLXSEG 

THN(2)  =  -DASIN(TT (1,3))  FLXSEG 

THN ( 3 )  =  DATAN2 (TT(2 ,3) ,TT(3,3))  FLXSEG 

THN (4)  =  1.0  FLXSEG 

CT22  =  1 . 0-TT ( 1 ,3) «»2  FLXSEG 

CT2  =  DSQRT (CT22)  FLXSEG 

ST2  =  -TT (1,3)  FLXSEG 

CT1  =  TT (1,1) /CT2  FLXSEG 

ST1  =  TT ( 1 , 2) /CT2  FLXSEG 

CNHl.l)  =  -  TT  (1,1)*  TT  (1,3)  /CT22  FLXSEG 

CN1(1,2)  =  - TT ( 1 , 2 ) » TT (1,3) /CT22  FLXSEG 

CNK1.3)  =  1.0  FLXSEG 

CN1 (2,1)  =  -ST1  FLXSEG 

CN1 (2,2)  =  CT1  FLXSEG 

CN1(2,3)  =  0.0  FLXSEG 

CNK3.1)  =  TT(  1 , 1)  /CT22  FLXSEG 

CN1 (3,2)  =  TT(1,2)/CT22  FLXSEG 

CN1 (3,3)  =  0.0  FLXSEG 

CALL  DOT31 (TT,WMEG(1 ,N3) ,WNM1)  FLXSEG 

DO  12  1=1,3  FLXSEG 

12  WNMl(I)  =  WNMl(I)  -  WMEG(I.Nl)  FLXSEG 

CALL  MAT3 1 (CN 1 , WNM1 , THND)  FLXSEG 

THND (4)  =  0.0  FLXSEG 

CALL  CROSS (WMEG( 1 , N 1 ) , WNM1 , WCSN)  FLXSEG 

RHSN(l)  =  (  (-THND( 1) »ST1»ST2  +  THND(2) «CT1/CT2) *WNM1 (1)  FLXSEG 

»  +(  THND  ( 1 )  »CT1»ST2  +  THND(2)  »ST1/CT2)  «WNIil  (2)  )/CT2  FLXSEG 

RHSN(2)  =  -THND (1 ) * (CT1*WNM1 ( 1)  +  ST1«WNM1(2))  FLXSEG 

RHSNC3)  =  (  ( -THND ( 1 ) *ST1  +  THND(2) »CT1«ST2/CT2) *WNM1 ( 1)  FLXSEG 


189 


*  +(  THND ( 1 ) »CT1  +  THND<2) *ST1*ST2/CT2) *WNM1 (2)  ) /CT2  FLXSEG 

13  N2  =  NFLEX(2 , IFX)  FLXSEG 

M  =  0  FLXSEG 

DO  15  1=1.3  FLXSEG 

DO  14  J=1 ,4  FLXSEG 

JM  =  J+M  FLXSEG 

GF ( I , J)  =  0.0  FLXSEG 

DO  14  K=1 ,4  FLXSEG 

14  GF (I , J)  =  GF(I.J)  +  HF (X , JM, IFX) *THN(K)  FLXSEG 

15  M  =  M+4  FLXSEG 

DO  17  1=1,3  FLXSEG 

THAI I)  =  0.0  FLXSEG 

THAD(I)  =0.0  FLXSEG 

DO  16  J=1 ,4  FLXSEG 

THA  (I)  =  THA  (I)  +  GF ( I , J) *THN  (J)  FLXSEG 

16  THAD(I)  =  THAD(I)  +  GF d , J) *THND (J)  FLXSEG 

THA  (I)  =  0.5*THA(I)  FLXSEG 

17  THADEG ( I )  =  THA(I) /RADIAN  FLXSEG 

CALL  DRCYPR  (DN2N1 , THADEG, IDYPR)  FLXSEG 

CALL  MAT33 (DN2N1 ,D ( 1 , 1 ,N1 ) , D ( 1 , 1 , N2) )  FLXSEG 

CSC  =  DCOS (THA (2) )  FLXSEG 

CSS  =  DSIN (THA (2) )  FLXSEG 

CN(l.l)  =  0.0  FLXSEG 

CN ( 2 , 1 )  =  0.0  FLXSEG 

CN (3 , 1 )  =  1.0  FLXSEG 

CN (1,2)  =  -DSIN(THAd) )  FLXSEG 

CN (2 , 2)  =  DCOS(THA(l) )  FLXSEG 

CN(3 , 2)  =  0.0  FLXSEG 

CN ( 1 ,3)  =  CSC»CN(2,2)  FLXSEG 

CN(2 , 3)  =  -CSC«CN (1,2)  FLXSEG 

CN(3 , 3)  =  -CSS  FLXSEG 

CALL  MAT33 (GF ,  CN1 ,  GC)  FLXSEG 

CALL  MAT33 (CN,  GC.  CGC)  FLXSEG 

CALL  DOT33  (D (1 , 1 ,N1) ,CGC ,B42 (1,1 ,3»IFX-2) )  FLXSEG 

CALL  DOTT33 (B42 ( 1 , 1 ,3*IFX-2) ,TT ,B42 ( 1 , 1 ,3* IFX) )  FLXSEG 

DO  20  1=1,3  FLXSEG 

DO  20  J=1 ,3  FLXSEG 

B42(I ,J,3*IFX-2)  =  B42(I,J,3*IFX-2)  -  D(J,I,N1)  FLXSEG 

B42 ( I , J , 3«IFX- 1 )  =  D(J, I ,N2)  FLXSEG 

20  B42 (I , J ,3*IFX  )  =  -B42 ( I , J ,3»IFX)  'LXSEG 

FLXSEG 

COMPUTE  V4  FLXSEG 

FLXSEG 

CALL  MAT31 (CGC ,  WNM1 . RHS1)  FLXSEG 

DO  21  1=1,3  FLXSEG 

21  RMG(I)  =  RHSKI)  +  WMEGd.Nl)  FLXSEG 

CALL  MAT31 (DN2N1 , RMG, WMEG( 1 ,N2) )  FLXSEG 

CALL  CROSS ( WMEG ( 1, N1 ) .RHS1.RHS2)  FLXSEG 

CALL  MAT31 (CGC.WCSN.RHS1)  FLXSEG 

DO  25  1=1,3  FLXSEG 


•S 

? 
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25  RHSKI)  =  RHS2  ( I )  -  RHSKI) 
CALL  MAT31 (GC ,  WNM1 ,RHS2) 


RHSl(l)  =  RHSl(l)  - 


RHS 1(2)  =  RHS1(2) 


THAD ( 1 ) * (CV (2,2) »RHS2 (2) -CN (1,2) »CSC»RHS2 (3) ) 
THAD (2) »CN(2 ,2) *CSS*RHS2 (3) 

THAD ( 1 ) * (CM ( 1 ,2) »RHS2 (2) +CN (2 , 2) »CSC»RHS2 (3) ) 
THAD (2) *CH( 1 , 2) »CSS«RHS2 (3) 

THAD (2) *CSC*RHS2 (3) 


RHS 1(3)  =  RHS 1(3)  -  THAD (2) »CSC»RHS2 (3) 

CALL  MAT31 (OF ,  RHSN,  RHS 2) 

M  =  1 

DO  30  1=1,3 
DO  26  J= 1 , 3 
PTD(J)  =0.0 
DO  26  K= 1 , 3 
KK  =  K+M-l 

26  PTD(J)  =  PTD(J)  +  HF( J ,KK, IFX) »THND(K) 

RHS2(I)  =  RHS2(I)  ♦  XDY(PTD,CH1  .WJflll) 

30  H  =  M+4 

CALL  MAT3KCH,  RHS 2 ,  PTD) 

DO  35  1=1,3 

35  RHSKI)  =  RHSKI)  +  PTD(I) 

CALL  D0T31 (D ( 1 , 1 , Nl) ,RHS1 , V4 ( 1 , IFX) ) 

IF  (IFX.EQ.NFLX)  GO  TO  98 
IFX  =  IFX+ 1 

IF  (NFLEX(l.IFX) .EQ.N1  .AND.  NFLEX(3, IFX) . EQ.N3)  GOTO  13 
GO  TO  11 

98  CALL  ELTIME(2 ,34) 

99  RETURN 
END 
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DOUBLE  PRECISION  FUNCTION  FNTERP ( THETA , PH I , NT )  FNTERP 

C  REV  IV  04/ 1O/07FNFIX 

C  COMPUTES  THE  RESTORING  TORQUE  OF  A  JOINT  AS  A  FUNCTION  OF  THE  FNTERP 

C  FLEXURE  ANGLE  (THETA)  AND  THE  AZIMUTH  ANGLE  (PHI)  AS  DEFINED  BY  FNTERP 

C  FUNCTION  NO.  NT  FNTERP 

C  FNTERP 

C  ASSUMES  0  <  THETA  <  PI  FNTERP 

C  -PI  <  PHI  <  PI  FNTERP 

C  DATA  IN  TAB  ARRAY  CONTAINS  NTHETA.NPHI  FOLLOWED  BY  FNTERP 

C  TWO  DIMENSIONAL  ARRAY  OF  FUNCTIONAL  VALUES  (NTHETA  >  0)  FNTERP 

C  OR  POLYNOMIAL  COEFFICIENTS  (NTHETA  <  0)  FOR  EQUALLY  FNTERP 

C  SPACED  VALUES  OF  PHI.  FNTERP 

C  FNTERP 

C  THETA ( I )  =  ( I  —  I ) *PI / ( NTHETA- 1 )  FOR  1  =  1, NTHETA  FNTERP 

C  PHI (J)  =  -PI  +  (J-1)*2»PI/NPHI  FOR  J=1,NPHI  FNTERP 

C  F (THETA, PI)  =  F (THETA, -PI)  FNTERP 

C  FNTERP 

C  SUBROUTINE  EVALUATES  G1 (THETA)  =  e (THETA, PHI (J)  )  FNTERP 

C  G2 (THETA)  =  F (THETA, PHI (J+l) )  FNTERP 

C  FOR  PHI (J)  <  PHI  <  PHI (J+I)  FNTERP 

C  B/  LINEAR  INTERPOLATION  OR  POLYNOMIAL  EVALUATION  AND  THEN  LINEAR  FNTERP 

C  INTERPOLATES  BETWEEN  G1  AND  G2  TO  OBTAIN  F (THETA, PHI ) .  FNTERP 

C  IF  F  <  0,  F  IS  SET  TO  ZERO,  THEREFORE  A  DEAD  BAND  IS  OBTAINED  FNTERP 

C  BY  NEGATIVE  VALUES  IN  THE  TABLE.  FNTERP 

C  FNTERP 

IMPLICIT  REAL* 8  (A-H.O-Z)  FNTERP 

COMMON/CNSNTS/  PI .RADIAN, G.THIBD.EPS (24) ,  FNTERP 

»  UNITL,UNITM,UNITT,GRAVTY(3) ,TWOPI  TWOPI 

COMMON/TABLES/MXNTI , MXNTB.MXTBl .MXTB2 ,NTI (50) ,NTAB(1250) .TAB (4500) DIMENB 
I ERROR  =  0  FNTERP 

IF  (PHI .LT. -PI)  I ERROR  =  1  FNTERP 

IF  (PHI .GT.  PI)  I ERROR  =  2  FNTERP 

IF  (THETA.LT. 0.0)  I ERROR  =  3  FNTERP 

IF  (THETA. GT. PI  )  I ERROR  =  4  FNTERP 

IF  (IERROR.NE.O)  WRITE  (6,11)  I ERROR, THETA, PHI , NT  FNTERP 

11  FORMAT (’0  IMPROPER  ARGUMENTS  TO  FUNCTION  FNTERP.  ERROR  CODE  =',I4/FNTERP 
»  ’0  THETA  =  ’  ,G25 . 15  ,  ’  PHI  =\G25.15,’  NT  =  \I6)  FNTERP 

IF  (IERROR.NE.O)  STOP  36  FNTERP 

NF  =  NTI (NT)  +  5  FNTERP 

NTHETA  =  TAB(NF)  FNTERP 

NPHI  =  TAB(NF+1)  FNTERP 

C  FNTERP 

C  DETERMINE  INDEX  AND  INTERPOLATION  PARAMETERS  FOR  PHI.  FNTERP 


IF  (PHI .GE . PI -EPS ( 15) )  PHI=0 . O-PI 
XNP  =  (PHI+PI) /TWOPI »TAB(NF+1) 

NP1  =  XNP 
NP2  =  NP1+1 

IF  (NP2.GE.NPHI)  NP2  =  0 
RP2  =  XNP  -  DFLOAT(NPl) 
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RPl  =  1.0  -  BP2 
MTH  =  IABS (NTHETA) 

IP1  =  NF+1+NP1*NTH 
IP2  =  NF+1*NP2*NTH 

DETERMINE  INDEX  AND  INTERPOLATION  PARAMETERS  FOR  THETA. 

IF  (NTHETA. LT.O)  GO  TO  20 
XNT  =  THETA/PI » (TAB (NF)- 1.0) 

NT  1  =  XNT 

RT2  =  XNT  -  DFLOAT(NTl) 

RT1  =  1.0  -  RT2 
IT1  =  IP1  ♦  NT1 
IT2  =  IP2  +  NT1 

G1  =  RT1«TAB(IT1+1)  ♦  RT2»TAB (IT1+2) 

G2  =  RT1*TAB(IT2+ 1)  +  RT2*TAB(IT2+2) 

GO  TO  23 

COMPUTE  FOR  POLYNOMIALS  IN  THETA  FOR  FIXED  PHI. 

20  NPOLY  =  -NTHETA- 1 

IT1  =  IP1  ♦  NPOLY  +  2 
IT2  =  IP2  ♦  NPOLY  +  2 
THETA 1  =  THETA  -  TAB(IP1+1) 

THETA2  =  THETA  -  TAB(IP2+1) 

GI  =  0.0 
G2  =  0.0 
DO  21  1=1 .NPOLY 
IT1  =  IT1-1 
IT2  =  IT2-1 

Gl  =  THETA1* ( TAB ( I T 1 ) +G1) 

21  G2  =  THETA2* (TAB(IT2) +G2) 

IF  (THETA1.LT. 0.0)  G1=0 . 0 
IF  (THETA2.LT. 0.0)  G2=0 . 0 

23  FNTERP  =  RP1*G1  +  RP2»G2 

IF  (FNTERP.LT. 0.0)  FNTERP  =  0.0 

RETURN 

END 
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SUBROUTINE  FRCDFL  (D , RATE ,  M,  N , FRCDF , ELOSS)  FRCDFL 

RET  I I I. 2  08/0B/84REVI II 

EVALUATE  FORCE  DEFLECTION  FUNCTION  AT  POINT  D,  WHERE  DEFINITION  FRCDFL 
OF  FUNCTION  IS  CONTROLLED  BY  M  INDEX  OF  NTAB  ARRAY.  FRCDFL 

DERIVATIVE,  FUNCTION  OR  INTEGRAL  IS  EVALUATED  AS  N  =  0,1  OR  2.  FRCDFL 
NTAB(M)  -  INDEX  TO  TAB  ARRAY  FOR  REAL  DATA  FRCDFL 

NTAB  (II*  1)  -  INDEX  TO  TAB  ARRAY  FOR  BASE  FUNCTION  FRCDFL 

NTAB (11*2)  -  INDEX  TO  TAB  ARRAY  FOR  INERTIAL  FUNCTION,  IF  ANY  FRCDFL 

FRCDFL 

ASSUMES  0  <  DG  <  DCUBIC  <  DREF  <  DMAX  FRCDFL 

BUT  ANY  <  MAY  BE  LESS  THAN  OR  EQUAL  TO  FRCDFL 

FRCDFL 

IMPLICIT  REAL«8 (A-H.O-Z)  FRCDFL 

COMMON/ TABLES /MXNT I , MXNTB , MXTB 1 , MXTB2 , NTI (50) , NTAB ( 1250) .TAB (4500) DIMENB 
F  =  0.0  FRCDFL 

ELOSS  =0.0  FRCDFL 

L  =  NTAB(M)  FRCDFL 

TAB (L)  =  D  FRCDFL 

IF  (D.LT.O.O)  GO  TO  99  FRCDFL 

DMAX  =  TAB (L+8)  FRCDFL 

IF  (D.LT.DMAX)  GO  TO  10  FRCDFL 

FRCDFL 

DMAX  <  D  ,  USE  MAX  VALUE  FRCDFL 

FRCDFL 

IF  (N-l)  99,9,99  FRCDFL 

9  FDMAX  =  TAB (L+ 10)  FRCDFL 

F  =  FDMAX  FRCDFL 

GO  TO  40  FRCDFL 

10  DREF  =  TAB(L+7)  FRCDFL 

IF  (D.GE.DREF)  GO  TO  30  FRCDFL 

DCUBIC  =  TAB(L+6)  FRCDFL 

IF  (DCUBIC. GE. DREF)  GO  TO  20  FRCDFL 

IF  (D.LE. DCUBIC)  GO  TO  20  FRCDFL 

FRCDFL 

DCUBIC  <  D  (  DREF  ,  USE  CUBIC  FRCDFL 

FRCDFL 

LC  =  L+14  FRCDFL 

DCO  =  TAB (L* 18)  FRCDFL 

X  =  D-DCO  FRCDFL 

IF  (N-l)  12,11,99  FRCDFL 

FRCDFL 

USE  CUBIC  DEFINITION  FRCDFL 

FRCDFL 

11  f  =  TAB (LC)  +  X  * (TAB(LC+1) *X« (TAB(LC+2) +X*TAB(LC+3) ) )  FRCDFL 

GO  TO  40  FRCDFL 

FRCDFL 

USE  DERIVATIVE  OF  CUBIC  FRCDFL 

FRCDFL 

12  F  =  TAB (LC* 1 ) +X# (2 , 0*TAB (LC+2) *X»3. 0*TAB(LC*3) )  FRCDFL 

GO  TO  99  FRCDFL 


o  o  o  o  o  o  o  a  rj  o  o  o  o  o  o  o  o  o 


20  DG  =  TAB(L+5)  FBCDFL 

IF  (D.LE.DG)  GO  TO  40  FRCDFL 

FRCDFL 

DG  <  D  <  DCUBIC  ,  OSE  QUADRATIC  FRCDFL 

FRCDFL 

LQ  =  L+ll  FRCDFL 

X  =  D-DG  FRCDFL 

IF  (N-l)  22,21,99  FRCDFL 

FRCDFL 

USE  QUADRATIC  DEFINITION  FRCDFL 

FRCDFL 

21  F  =  TAB (LQ) +X* (TAB ( LQ  + 1 ) +X»TAB (LQ+2) )  FRCDFL 

GO  TO  40  FRCDFL 

FRCDFL 

USE  DERIVATIVE  OF  QUADRATIC.  FRCDFL 

FRCDFL 

22  F  =  TAB (LQ+1)+X«2.0»TAB (LQ+2)  FRCDFL 

GO  TO  99  FRCDFL 

FRCDFL 

DREF  <  D  <  DMAX,  USE  BASE  FUNCTION  FBCDFL 

FRCDFL 

30  IF  (N-l)  31,31,99  FRCDFL 

31  NB  *  NTAB(M+1)  FBCDFL 

FRCDFL 

EVALUATE  BASE  FUNCTION  FRCDFL 

FRCDFL 

IF  (NB.GT.O)  F  =  EVALFD (D ,NB ,N)  FRCDFL 

NI  =  NTAB (M+2)  FRCDFL 

FBCDFL 

ADD  INERTIAL  FUNCTION  ,  IF  ANY  FRCDFL 

FRCDFL 

IF  (NI.GT.O)  F  =  F+EVALFD(D,NI ,N)  FRCDFL 

40  IF  (N.NE.l)  GO  TO  99  FRCDFL 

C  FRCDFL 

C  COMPUTE  AND  ADD  RATE  DEPENDENT  FUNCTIONS,  IF  ANY.  FRCDFL 

C  FRCDFL 

C  CURRENT  RESTRICTIONS:  FRCDFL 

C  FRCDFL 

C  1)  COMPUTED  FOR  N=1  (FUNCTION)  ONLY.  FBCDFL 

C  FRCDFL 

C  2)  FUNCTION  NOS.  M+2.M+3  AND  M+4  (USED  FOR  INERTIAL  SPIKE,  FRCDFL 

C  R  FACTOR  AND  G  FACTOR  FUNCTIONS)  MUST  BE  NEGATIVE  OR  ZERO,  FRCDFL 

C  I.E.,  THESE  FUNCTIONS  CANNOT  BE  USED  IN  CONJUNCTION  WITH  FBCDFL 

C  THE  RATE  DEPENDENT  FUNCTIONS.  FBCDFL 

C  FRCDFL 

C  3)  ASSUMES  THE  FUNCTIONAL  FORM  FRCDFL 

C  FRCDFL 

C  F(D,D' )  «  F1(D)  ♦  F2(D)«F3(D’)  ♦  F4(D’)  FRCDFL 

C  FRCDFL 

C  WHERE  FUD  )  IS  DEFINED  BY  FUNCTION  NTAB(M+1)>0,  FRCDFL 


I.E.,  NORMAL  FORCE  DEFLECTION  FUNCTION  WITH  NO  FRCDFL 
INERTIAL  SPIKE  FUNCTION  AND  DEFAULT  VALUES  FRCDFL 

R= 1  AND  0=0  (UNLOADING  AND  RELOADING  SAME  AS  FRCDFL 
ORIGINAL  LOADING);  FRCDFL 

FRCDFL 

F2(D  )  IS  DEFINED  BY  FUNCTION  NTAB(M+2)<0,  FRCDFL 

IF  NTAB(M+2)=0,  F2(D  ) =0;  FRCDFL 

FRCDFL 

F3(D’)  IS  DEFINED  BY  FUNCTION  NTAB(M+3X0,  FRCnFL 

IF  NTAB(M+3) =0 ,  F3(D')=0;  FRCDFL 

FRCDFL 

AND  F4 (D* )  IS  DEFINED  BY  FUNCTION  NTAB (M+4) <0.  FRCDFL 

IF  NTAB (M+4) =0 ,  F4(D’)=0.  FRCDFL 

FRCDFL 

NOTE:  FUNCTIONAL  FORM  CAN  BE  CHANGED  BY  REVISING  PROGRAM  FRCDFL 


BETWEEN  STATEMENTS  40 

AND  99. 

FRCDFL 

FRCDFL 

F2  =  0.0 

FRCDFL 

F3  =  0.0 

FRCDFL 

F4  =  0.0 

FRCDFL 

N2  =  -NTAB(M+2) 

FRCDFL 

N3  =  -NTAB(M+3) 

FRCDFL 

N4  =  -NTAB (M+4) 

FRCDFL 

IF  (N2.GT.0)  F2  =  EVALFD 

(D,  N2,N) 

FRCDFL 

IF  (N3.GT.0)  F3  =  EVALFD 

(RATE.N3.N) 

FRCDFL 

IF  (N4.GT.0)  F4  =  EVALFD 

(RATE ,N4 ,N) 

FRCDFL 

F  =  F  +  F2*F3  +  F4 

FBCDFL 

ELOSS  =  RATE* (F2*F3+F4) 

FRCDFL 

FRCDF  =  F 

FRCDFL 

RETURN 

FRCDFL 

END 

FRCDFL 

SUBROUTINE  FSMSOL  (C , R.NN.MX.MAXN, JN.MAXDIM)  FSMSOL 

RET  I I I. 2  08/08/84REVI I I 
SOLVES  A  SET  OF  SIMULTANEOUS  EQUATIONS  OF  SIZE  3«MM  FSMSOL 

WHERE  THE  MATRIX  CONSISTS  OF  A  SET  OF  3*3  SUBMATRICES  FSMSOL 

STORED  IN  C (3 ,3 , IJ) .  THE  LOCATION  OF  THE  I ,J  ELEMENT  FSMSOL 

IS  STORED  IN  NN( I , J) .  I.E.  IJ=NN(I,J)  FSMSOL 

FSMSOL 

A  NEGATIVE  IJ  IMPLIES  THAT  C(  ,  ,sIJ!)  IS  AN  FSMSOL 

IDENTITY  AND  THE  RIGHT  SIDE  IS  ZERO.  A  NEGATIVE  FSMSOL 

IJ  WILL  ONLY  OCCUR  ON  A  DIAGONAL  ENTRY  OF  NN.  FSMSOL 

FSMSOL 

THE  BASIC  EQUATION  IS  CX=R  FSMSOL 

FSMSOL 

DURING  THE  SOLUTION  THE  C  MATRIX  IS  DESTROYED  , IT  MAY  FSMSOL 

BE  NECESSARY  TO  ADD  TO  THE  C  ARRAY.  FSMSOL 

THE  SOLUTION  IS  STORED  IN  R.  FSMSOL 

FSMSOL 

INPUT  FSMSOL 

FSMSOL 

C(3,3,K)  GIVEN  ARRAY  FSMSOL 

R(3 ,MM)  GIVEN  RIGHT  HAND  SIDE  FSMSOL 

NN(JJ.JJ)  GIVEN  ARRAY  CONTAINING  LOCATIONS  OF  I, J, ELEMENT  FSMSOL 

MX  SIZE  OF  SYSTEM  OF  SUBMATRICES  (POSITIVE  INDICATES  FSMSOL 

THAT  C  MATRIX  IS  SYMMETRIC.  NEGATIVE  IT  IS  NOT.)  FSMSOL 
MAXN  LARGEST  VALUE  IN  NN  ARRAY  FSMSOL 

JN  DIMENSION  OF  NN  FSMSOL 

MAXDIM  THIRD  DIMENSION  OF  C  IN  CALLING  ROUTINE  FSMSOL 

FSMSOL 

IMPLICIT  REAL *8  (A-H.O-Z)  FSMSOL 

COMMON/CONTRL/  TIME , NSEG , NJNT , NPL , NBLT , NBAG , NVEH , NGRND ,  PAGE 

*  NS , NQ , NSD , NFLX , NHRNSS , NWINDF , NJNTF , NPRT ( 36 ) , NPG  PAGE 

DIMENSION  C(3,3,l) , R ( 3 , 1 ) , NN ( JN , 1 )  FSMSOL 

CALL  ELTIME ( I , 20)  FSMSOL 

MM  =  IABS(MX)  FSMSOL 

IF  (MM.LE.O)  GO  TO  99  FSMSOL 

MM1  =  MM- I  FSMSOL 

MP1  =  MM+1  FSMSOL 


DO  50  11=1, MM 

I  =  MP1-II 

START  PIVOT  AT  BOTTOM  -  FIND  PIVOT  - 
L  =  NN (1,1) 

IF  (L.LE.O)  GO  TO  50 
DO  14  M=  1 , 3 
B  =  1 . 0/C (M,M,L) 

C (M.M.L)  =  1.0 
C(M.l.L)  =  B*C (M, 1 ,L) 

C (M, 2 ,L)  =  B*C (M, 2 , L) 

C (M,3 ,L)  =  B»C(M,3,L) 


FSMSOL 

FSMSOL 

FSMSOL 

INVERT.  FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 


R(M.I)  =  B»R(M, I ) 

FSMSOL 

DO  13  N=  1 ,3 

FSMSOL 

IF  (N.EQ.M)  GO  TO  13 

FSMSOL 

B  =  C  (N,M,L) 

FSMSOL 

C (N,M,L)  =  0.0 

FSMSOL 

C(N,  1 ,L)  =  C (N, 1 ,L)  -  B*C (M, 1 , L) 

FSMSOL 

C(N,2,L)  =  C (N, 2 ,L)  -  B«C(M,2,L) 

FSMSOL 

C(N,3,L)  =  C (N,3 ,L)  -  B»C(M,3,L) 

FSMSOL 

R(N, I)  =  R(N, I)  -  B*R(M, I ) 

FSMSOL 

13 

CONTINUE 

FSMSOL 

14 

CONTI NOE 

FSMSOL 

c 

FSMSOL 

c 

CHECK  IF  DONE. 

FSMSOL 

c 

FSMSOL 

IF  (I.EQ.l)  GO  TO  50 

FSMSOL 

IM1  =  1-1 

FSMSOL 

c 

FSMSOL 

c 

CALCULATE  PIVOT  ROW. 

FSMSOL 

c 

FSMSOL 

DO  20  J=  1 , IM1 

FSMSOL 

IF  (NN(I,J) .EQ.O)  GO  TO  20 

FSMSOL 

M  =  NN( I , J) 

FSMSOL 

DO  15  N=  1 , 3 

FSMSOL 

A  =  C  ( 1 , 1 ,L) *C  ( 1  ,N,M)  +  C  ( 1 , 2  ,L)  *C  (2  ,N , M) 

♦  C ( 1 ,3 ,L) *C (3 ,N,M) 

FSMSOL 

B  =  C (2 . 1 ,L) *C ( 1 , N,M)  +  C (2 , 2 ,L) »C (2 ,N,M) 

+  C (2 ,3 ,L) *C (3  ,N,M) 

FSMSOL 

D  =  C (3 , 1 ,L) »C ( 1 ,N,M)  ♦  C (3 , 2 ,L) «C (2 ,N,M) 

♦  C(3,3,L)«C(3,N,M) 

FSMSOL 

C(l.N.M)  =  A 

FSMSOL 

C  ( 2 ,  N ,  M)  =  B 

FSMSOL 

15 

C (3 ,N,M)  =  D 

FSMSOL 

20 

CONTINUE 

FSMSOL 

c 

FSMSOL 

c 

DONE  WITH  PIVOT  ROW  -  ZERO  COLUMN  I  ABOVE 

DIAGONAL. 

FSMSOL 

c 

FSMSOL 

c 

1.1 

FSMSOL 

c 

. 

FSMSOL 

c 

. 

FSMSOL 

c 

K.K  .  .  K,J  .  .  K , I 

C  =  C  -  C  «C 

FSMSOL 

c 

. 

KJ  KJ  KI  IJ 

FSMSOL 

c 

. 

FSMSOL 

c 

J ,K  .  .  J,J  .  .  J,I 

C  =  C  -  C  «C 

FSMSOL 

c 

. 

JK  JK  JI  IK 

FSMSOL 

c 

. 

FSMSOL 

c 

I ,K  .  .  I,J  .  .  I.I 

C  =0 

FSMSOL 

c 

. 

KI 

FSMSOL 

c 

. 

FSMSOL 

c 

M.M 

FSMSOL 

c 

FSMSOL 

DO  40  K=1 , IM1 

FSMSOL 

KI  =  NN(K.I) 

FSMSOL 

IK  =  NN(I.K) 

FSMSOL 
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IF  (K1.EQ.0  .AND.  IK.EQ.O) 
DO  30  J=K,IM1 
IJ  =  NN ( I ,J) 

JI  =  NN ( J , I ) 

IF  (KI.EQ.O  .OR.  IJ 
KJ  =  NN(K.J) 

IF  (KJ.NE.O)  GO  TO 
MAXN  =  MAXN+1 
IF  (MAXN.GT.MAXDIM) 

KJ  =  MAXN 
NN (K,J)  =  KJ 
DO  21  M=l,3 

DO  21  N=  1 , 3 
C (N,M,KJ)  =  0.0 
DO  23  M=  1 , 3 
DO  23  N=1 ,3 

C (N,M,KJ)  =  C(N.M.KJ) 


GO  TO  22 


GO  TO  40 


IJ.EQ.O)  GO  TO  24 


GO  TO  41 


IF  (J.EQ.K)  GO  TO  30 
IF  (JI.EQ.O  .OR.  IK. E 
JK  =  NN(J.K) 

IF  (JK.NE.O)  GO  TO  26 
MAXN  ?  MAXN+1 
IF  (MAXN.GT.MAXDIM)  G 
JK  =  MAXN 
NN ( J ,K)  =  JK 
DO  25  M= 1 , 3 
DO  25  N=1 ,3 

C(N.M.JK)  =  0.0 
IF  (MX.LT.O)  GO  TO  28 
DO  27  M= 1 , 3 
DO  27  N=  1 , 3 
C(N.M.JK)  =  C(M.N.KJ) 

GO  TO  30 
DO  29  M= 1 , 3 
DO  29  N= 1 , 3 
C(N.M.JK)  =  C(N.M.JK)  - 


N.M.KJ)  -  C (N, 1 ,KI) *C ( 1 , M, IJ) 

-  C(N,2,KI)*C(2,M,IJ) 

-  C(N,3,KI)*C(3,M,IJ) 

GO  TO  30 

.OR.  IK.EQ.O)  GO  TO  30 


GO  TO  41 


C (N, 1 , JI) *C ( 1 , M, IK) 
C(N,2,JI)»C(2,M,IK) 
C(N.3,JI)*C(3tM,IK) 


30  CONTINUE 

IF  (KI.EQ.O)  GO  TO  40 
DO  35  N= 1 ,3 

35  R(N,K)  =  R(N,K)  -  C(N, 1 ,KI) «R(1 ,1) 

»  -  C (N , 2 ,KI) «R(2 f I) 

»  -  C(N,3,KI) »R(3,I) 

40  CONTINUE 
50  CONTINUE 

GO  TO  51 

41  WRITE  (6,49)  MAXDIM.NPG, (L ,L= 1 ,MM) 


FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

FSMSOL 

PAGE 
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NPG=NPG+1  PAGE 

DO  42  1=1, MM  FSMSOL 

42  WRITE  (6,43)  I , (NN(I ,L) ,L=1 ,MM)  FSMSOL 

43  F0RMAT(I3,3X, 4013, 3X/6X, 4013)  FSMSOL 

WRITE  (6,44)  NPG  PAGE 

NPG=NPG+ 1  PAGE 

44  FORMAT ( ’ 1  FSMSOL  PRINT  OF  RHS  ARRAY’ ,96X, ’PAGE’ , 15//)  PAGE 

DO  45  K= 1 ,MM  FSMSOL 

45  WRITE  (6,46)  K , (R(I ,K) , 1=1 , 3)  FSMSOL 

46  FORMAT (16 ,9G14 .7)  FSMSOL 

WRITE  (6,47)  NPG  PAGE 

NPG=NPG+1  PAGE 

47  FORMAT ( *  1  FSMSOL  PRINT  OF  C  ARRAY  ELEMENTS’ ,89X, ’PAGE* , 15//)  PAGE 

DO  48  K= 1 , MAXN  FSMSOL 

48  WRITE  (6,46)  K, ( (C (I ,L,K) ,L=1 .3) , 1=1 ,3)  FSMSOL 

49  FORMAT ( ’ 1  MAXIMUM  DIMENSION  OF ’,14,’  ON  C  ARRAY  HAS  BEEN  EXCEEDED  FSMSOL 

»IN  SUBROUTINE  FSMSOL. ’ ,46X, ’PAGE’ ,15//’  IF  600,  CALL  IS  FROM  SUBROPAGE 
»UTINE  DAUX.  IF  200’  PAGE 

»  ,’  CALL  IS  FROM  SUBROUTINE  HPTURB . ’ / / ’  PROGRAM  IS  BEING  TERMI NATEPAGE 
*D.  COMPLETE  PRINT-OUT  OF  IJK,  RHS  AND  C  ARRAYS  FOLLOW.’//  FSMSOL 

»’  FSMSOL  PRINT  OF  IJK  MATRIX’ // (6X, 4013) )  FSMSOL 

STOP  35  FSMSOL 

C  FSMSOL 

C  BACKDOWN  SOLUTION  FSMSOL 

C  FSMSOL 

51  IF  (MM.EQ.l)  GO  TO  99  FSMSOL 

DO  90  J=1 ,MM1  FSMSOL 

IP  =  J+l  FSMSOL 

DO  80  I=IP,MM  FSMSOL 

IF  (HN(I.J).EQ.O)  GO  TO  80  FSMSOL 

IJ  =  NN(I,J)  FSMSOL 

DO  75  N= 1 ,3  FSMSOL 

75  R(N, I)  =  R(N, I)  -  C (N, 1 , IJ) *R( 1 , J)  FSMSOL 

*  -  C(N,2,IJ)»R(2,J)  FSMSOL 

*  -  C (N, 3 , IJ) *R(3 , J)  FSMSOL 

80  CONTINUE  FSMSOL 

90  CONTINUE  FSMSOL 

99  CALL  ELTIME (2 , 20)  FSMSOL 

RETURN  FSMSOL 

END  FSMSOL 
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SUBROUTINE  GLOBAL  ( J , HD3 , DH 1 , TQC , T9 , ANGL ) 

REV  IV  07/24/ 

IMPLICIT  REAL»8  (A-H.O-Z) 

DIMENSION  HD3 (3)  ,DH1(3.3)  ,T9(3)  , ANGLO)  ,CC(3) 

COMMON/DESCRP/  PHI (3,30) ,W(30) ,RW(30) ,SR(4,60) ,HA(3,60) ,HB(3,60) 

*  RPHI  (3,30)  ,  HT  (3 , 3 , 60)  ,  SPRINGO ,  90)  ,VISC(7,90)  , 

*  JNT  (30)  ,  IPIN(30)  .ISINGOO)  .IGLOBOO)  .JOINTFOO) 


GLOBAL 

07/24/86SLIP 

GLOBAL 


GLOBAL 

SLIP 

GLOBAL 

GLOBAL 


COMMON/ TABLES /MXNT I .MXNTB.MXTBl .MXTB2 ,NTI (50) ,NTAB(1250) ,TAB(4500) DIMENB 


COMMON/ TEMP  VI/  CREST, TTK3)  ,R1I(3)  ,R2I(3)  .  JSTOP(4 , 2 ,30) 
COMMON/CNSNTS/  PI , RADIAN, G, THIRD.EPS (24) , 

*  CJNITL .UNITM.UNITT ,GRAVTY(3)  .TWOPI 

IF  (DABS (HD3 (3) ) . GT, 1 . 0-EPS (6) )  GO  TO  34 
ANGL ( 1 )  =  DACOS (HD3 (3) ) 

NT  =  I GLOB (J) 

NT  I  =  NTAP (NT+2) 

CALL  HERRON ( HD3 , NT  I , THETO , THETOP ) 

JSTOP (4 , 1 , J)  =  0 
IF  (ANGL(l) .LE. THETO)  GO  TO  34 
JSTOP(4 , 1 , J)  =  1 
MT  =  NTAB (NT+5) 

CREST  =  TAB(MT+3) 

STH2  =  1 . 0-HD3 (3) **2 
STH  =  DSQRT (STH2) 

CTH  =  HD3 (3) /STH 

CST  =  DSQRT (STH2+THET0P»»2) 

DR  =  (ANGL(l) -THETO) »STH/CST 
LT  =  NTAB(NT) 

TAB (LT)  =  DR 
NT AB (NT+2)  =  0 
DRDOT  =0.0 

CALL  FRCDFL  (DR. DRDOT, NT. 1 .TQF.ELOSS) 

NT AB (NT+2)  =  NT1 
TQC  =  TQF/CST 

CC(I)  =  -HD3 (2) +HD3 ( 1 ) »CTH»THETOP 
CC (2)  =  HD3 ( I) +HD3 (2) *CTH»THETOP 
CC (3)  =  -STH#THETOP 

DO  28  L=  1 , 3 

28  T9 (L)  =  CC ( I ) »DH1 (L  ,  1 )  ♦  CC (2) »DH1 (L , 2)  ♦  CC (3) »DH1 (L , 3! 


CC (2) »DH1 (L , 2)  ♦  CC (3) *DH1 (L ,3) 


34  RETURN 
END 


GLOBAL 

GLOBAL 

TWOPI 

GLOBAL 

GLOBAL 

GLOBAL 

GLOBAL 

GLOBAL 

GLOBAL 

GLOBAL 

GLOBAL 

GLOBAL 

GLOBAL 

GLOBAL 

GLOBAL 

GLOBAL 

GLOBAL 

GLOBAL 

GLOBAL 

GLOBAL 

GLOBAL 

GLOBAL 

GLOBAL 

GLOBAL 

GLOBAL 

GLOBAL 

GLOBAL 

GLOBAL 

GLOBAL 

GLOBAL 

GLOBAL 

GLOBAL 
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SUBROUTINE  HBELT  ( J1 , J2 ,KNL0 , IND) 


REV  IV 


ARGUMENTS : 
JI.J2 
KNLO 
IND 


FIRST  AND  LAST  INDEX  FOR  BELTS. 
ZERO  VALUE  FOR  KNL  INDEX. 

0:  CALL  IS  FROM  SUBROUTINE  CONTCT 
1:  CALL  IS  FROM  SUBROUTINE  UPDATE 


IMPLICIT  REAL *8  (A-H.O-Z) 

COMMON/CNTSRF /  PL(24,30) ,BELT(20,8) tTPTS(6,8) ,BD(24,40) 
COMMON/CNSNTS /  PI , RADI AN, G, THIRD, EPS (24) , 

*  UNITL.UNITM.UNITT.GRAVTYO)  .TWOPI 


HBELT 

02/01/88MISDOT 

HBELT 

HBELT 

HBELT 

HBELT 

HBELT 

HBELT 

HBELT 

EDGE 

MISDOT 

MISDOT 


COMMON/SGMNTS/  D(3,3,30) ,WMEG(3,30) ,WMEGD(3,30) ,U1(3,30) ,U2(3,30) .HBELT 

*  SEGLP(3,30) ,SEGLV(3,30) ,SEGLA(3,30) ,NSYM(30)  HBELT 

COMMON/TABLES/MXNTI .MXNTB.MXTBI .MXTB2.NTI (50) ,NTAB(1250) .TAB (4500) DIMENB 
COMMON/FORCES/PSF (7,70) ,BSF(4,20) ,SSF(10,40) ,BAGSF(3,20) ,  NCFORC 

*  PRJNT(7,30) ,NPANEL(5) , NPSF.NBSF.NSSF.NBGSF  HBELT 

COMMON/HRNESS/  BAR(15, 100) ,BB(100) .BBDOT(IOO) ,PLOSS(2, 100) ,  HBELT 

»  XLONG(20) , HTIME (2) , IBAR(5 , 100) ,NL(2 , 100) ,  HBELT 

*  NPTSPB ( 20 ) . NPTPLY ( 20 ) , NTHRNS ( 20 ) . NBLTPH ( 5 )  HBELT 

THIS  COMMON/TEMP VS/  IS  SHARED  BY  HPTURB ,  HBPLAY,  HBELT  AND  HSETC.  HBELT 
COMMON/TEMPVS/  B(3 .3 , 3) ,S (3 ,3) ,T(3) ,R(3) ,V(3) ,T1 (3) ,T2 (3) ,  HBELT 

»  E(3,3,50) ,EDOT(3,50) ,FCE(3,50) ,FR(3,50) ,ZR(3,50) ,  HBELT 

»  TR(3 , 50) ,U(3,50) .PTLOSS (2 . 50) ,BL(50) ,FB(50) ,FP(50) .HBELT 


»  OLDBB(IOO) ,RHS (3 , 54) ,C(3.3.200) ,IJK(54,54) 

CALL  ELTIME  (1,38) 

NTP  =  0 
K2  =  0 

DO  31  JB=J1 . J2 
IF  (IND.EQ.O)  NBSF  =  NBSF  +  1 
IF  (NPTPLY ( JB) .LE.O)  GO  TO  31 

FIRST  LOOP  ON  K 

COMPUTE  Z(K) ,ZR(X) ,E3(K) ,U(K-1) ,BL(K-1) ,FB(K-1) 

NEED  NL(K) .BB(K-l) 

NOTE:  AN  INDEX  K-l  REFERS  TO  BELT  SEGMENT  BETWEEN  K-l  AND  K. 

KI  =  K2  +  1 

K2  =  K2  +  NPTPLY (JB) 

DO  20  K=K1 ,K2 
KNL  =  KNLO  +  K 
KI  =  NL(l.KNL) 

HERE  K  IS  INDEX  OF  POINTS  IN  PLAY  ON  EACH  HARNESS 
KNL  IS  INDEX  OF  ALL  POINTS  IN  PLAY 


HBELT 

HBELT 

HBELT 

HBELT 

HBELT 

HBELT 

HBELT 

HBELT 

HBELT 

HBELT 

HBELT 

HBELT 

HBELT 

HBELT 

HBELT 

HBELT 

HBELT 

HBELT 

HBELT 

HBELT 

HBELT 


C 

KI  IS  INDEX  OF  ALL  POINTS 

HBELT 

C 

HBELT 

t?;v 

KS 

=  IABSdBAR(l.KI)) 

HBELT 

IF 

(KS.GT.100)  NTP  =  1 

HBELT 

u-*  * 

IF 

(KS.GT.100)  KS  =  MOD (KS, 100) 

HBELT 

v.V, 

>".w 

202 

o  o 


KE  =  I BAR ( 2 , X I )  HBELT 

CALL  D0T31  (D( 1 . 1 ,KS) ,BAR(4 ,KI) ,T1)  HBELT 

CALL  D0T31  (D ( 1 . 1 ,KS) ,BAR(7 ,KI) ,T2)  HBELT 

DO  11  J=  1 , 3  HBELT 

R(J)  =  V(J)  HBELT 

V(J)  =  BAR( J+3 , K I )  ♦  BAR(J+6 ,KI)  HBELT 

TR(J,K)  =  T1(J)  HBELT 

ZR(J.K)  =  T 1 ( J )  ♦  T2(J)  HBELT 

S  (J,2)  =  S ( J , 1)  HBELT 

11  S  (J.l)  =  SEGLP(J.KS)  ♦  ZR(J ,K)  HBELT 

CALL  CROSS  (WMEGU ,KS) ,V,T)  HBELT 

IF  (KE.EQ.O)  GO  TO  12  HBELT 

CALL  MAT31  (BD(7,KE) ,BAR(4,KI) ,T2)  HBELT 

CALL  DOTS  1  (D(l.l.KS) .T2.T1)  HBELT 

12  DO  13  J=1 ,3  HBELT 

T ( J)  =  T ( J)  ♦  BARCJ+12 , K I )  HBELT 

13  E (J ,3 ,K)  =  T1(J)  HBELT 

CALL  DOT31  (D( 1 , 1 ,KS) ,T,V)  HBELT 

DO  14  J= 1 ,3  HBELT 

14  V ( J)  =  V ( J)  ♦  SEGLV(J.KS)  HBELT 

FB (K)  =  0.0  HBELT 

FP (K)  =  0.0  HBELT 

IF  (K.EQ.K1)  GO  TO  20  HBELT 

DO  15  J=  1 .3  HBELT 

15  O(J.K-l)  =  S(J,1)  -  S (J .2)  HBELT 

BL(K-l)  '  DSQRT(U(1 , K- 1 ) » * 2  ♦  U(2,K-1)*«2  ♦  U(3,K-1)**2)  HBELT 

DO  16  J= 1 , 3  HBELT 

16  U(J.K-l)  =  0(J,K-1) /BL(K-l)  HBELT 

STRAIN  =  (BL(K-l) /BB (KNL- 1) )  -  1.0  HBELT 

IF  (STRAIN. LT.EPS(12))  STRAIN  *  0.0  MISDOT 

NT  =  NL (2 .KNL)  HBELT 

BLDOT  =  D(1,K-1)*(V(1)-R(1))  HBELT 

*  *  U(2 ,K-1) * (V(2) -R(2) )  HBELT 

•  ♦  U(3,K-1)MV(3)-R(3))  HBELT 

STRDOT  =  (BB (KNL- 1 ) *BLDOT-BL ( K - 1 ) »BBDOT (KNL- 1) ) /BB (KNL- 1 ) >«2  HBELT 

CALL  FRCDFL  ( STRAIN, STRDOT, NT, 0 ,FPK,ELOSS)  HBELT 

CALL  FRCDFL  (STRAIN, STRDOT, NT, 1 ,FBK,ELOSS)  HBELT 

PTLOSS ( 1 ,K- 1 )  =  BB (KNL- 1 ) »ELOSS  HBELT 

FP(K-l)  =  FPK  HBELT 

FB(K-l)  =  FBK  HBELT 

IF  (IND.NE.O)  GO  TO  20  ENDPFX 

IF  (K.NE.KH1)  GO  TO  18  ENDPFX 

BSF(l.NBSF)  =  STRAIN  ENDPFX 

BSF(2,NBSF)  =  FBK  ENDPFX 

19  IF  (K.NE.K2)  GO  TO  20  ENDPFX 

BSF (3.NBSF)  =  STRAIN  ENDPFX 

BSF (4 , NBSF)  =  FBK  ENDPFX 

20  CONTINUE  HBELT 

HBELT 

SECOND  LOOP  ON  K  HBELT 


^EaC  c  COMPUTE  FCE(X)  .  El  (X)  , Z2 (X)  , EDOT  (K)  ,FB(X)  ,  D1  (XS)  ,02  (KS)  HBELT 

■  C  NEED  FB(K&K-1) ,U(K&K-1) ,ZB(K) ,E3(K)  HBELT 

[ft  C  HBELT 

Rfi  DO  30  K=K1,K2  HBELT 

|ft  KNL  =  KHLO  +  K  HBELT 

KJ.  KI  =  NL(1,KBL)  HBELT 

u™  KS  IABS(IBAB(1,KD)  HBELT 

IF  (KS.GT.100)  KS  =  MOD(KS.IOO)  HBELT 

DO  21  J=1 ,3  HBELT 

FCE(J ,K)  =  0.0  BUTLER 1 

IF  (K.NE.K2)  FCE(J.K)  =  FB(K)*U(J,K)  BUTLER 1 

jjg  21  IF  (K.NE.K1)  FCE(J.K)  =  FCE(J.K)  -  FB(K-1)*U(J,K-1)  HBELT 

m  NT  =  IBAR(3,XI)  HBELT 

JP  NF  =  NTAB  (NT+5)  HBELT 

K  IF  (NF.EQ.O  .AND.  IND.EQ.O)  GO  TO  30  HBELT 

IF  (IBAR(4,KI) . EQ.O)  GO  TO  22  HBELT 

CALL  D0T31  (D ( 1 , 1 ,KS) ,BAR(10,KI) ,T1)  HBELT 

GO  TO  24  HBELT 

22  DO  23  J=1 ,3  HBELT 

JL  T1(J)  =  0.0  HBELT 


23 

24 


& 

ft 


25 

30 

31 


C 

C 

C 


IF  (K.NE.K2)  T1(J)  =  U(J,K) 

IF  (K.NE.K1)  T1(J)  =  T1(J)  ♦  U(J,K-1) 

CALL  CROSS  (T1,E(1,3,K) ,E ( 1 , 1 ,K) ) 

CALL  CROSS  (E(1,3,K) , E( 1 , 1 ,K) , E( 1 , 2 ,K) ) 

DO  25  J=l,3 

EDOT(J.K)  *  DSQRT(ECI,J,K)*«2  ♦  E(2,J,K)««2  ♦  E(3,J,K)««2) 
DO  25  1=1,3 

E(I ,J,K)  =  E(I ,J,K)/EDOT(J,K) 

CALL  D0T31  (E( 1 , 1 ,K) ,FCE( 1 ,K) ,FR(1 ,K) ) 

CONTINUE 

CONTINUE 

IF  (NTP.LE.O)  GO  TO  41 

SUM  FCE.FR  FOR  TIE-POINTS 

KNL1  =  KNLO  ♦  2 
KNL2  =  KNLO  ♦  K2 
DO  40  KNL=KNL1 ,KNL2 
KI  *  XLU.KN L) 

KS  =  IABS(IBAR(1 ,KI) ) 

IF  (KS.LT.100)  GO  TO  40 
KS1  =  KS/100 
KH  =  KNL  -  KNLO 
MH  =  0 

DO  38  JNL=KNL1 , KNL 
KI  =  NL( 1 , JNL-1) 

KS  =  IABS(IBAR(1 , KI ) ) 

IF  (KS.LT.100)  GO  TO  38 
KS2  =  KS/100 

IF  (KS2.NE.KS1)  GO  TO  38 


HBELT 

HBELT 

HBELT 

HBELT 

HBELT 

HBELT 

HBELT 

HBELT 

HBELT 

HBELT 

HBELT 

HBELT 

HBELT 

HBELT 

HBELT 

HBELT 

HBELT 

HBELT 

HBELT 

HBELT 

HBELT 

HBELT 

HBELT 

HBELT 

HBELT 

HBELT 

HBELT 

HBELT 

HBELT 

HBELT 


JH  =  JNL-1  -  KHLO  HBELT 

IF  (MH.EQ.O)  MH  =  JH  HBELT 

DO  37  J=1 ,3  HBELT 

IF  IMH.EQ.JH)  FCE(J ,MH)  =  FCE(J.MH)  ♦  FCE(J.KH)  HBELT 

37  FCE(J.JH)  =  FCE ( J , MH)  HBELT 

CALL  DOT3I  (E(l , 1 , JH) ,FCE(1 , JH) ,FB(1 ,JH) )  HBELT 

38  CONTINUE  HBELT 

IF  ( MH.EQ.O)  GO  TO  40  HBELT 

KI  =  NL(l.KNL)  HBELT 

IBARd.KI)  =  -IABS(IBAR(1 ,KI) )  HBELT 

DO  39  J=1 ,3  HBELT 

39  FCE(J.KH)  =  FCE(J.MH)  HBELT 

CALL  D0T31  (E ( 1 , 1 ,KH) , FCE ( 1 ,KH) ,FB( 1 ,KH) )  HBELT 

40  CONTINUE  HBELT 

C  HBELT 

C  IF  CALL  IS  FROM  SUBROUTINE  CONTCT,  HBELT 

C  ADD  FORCES  (FCE)  MODIFIED  BT  FRICTION  TO  U1.U2  ARRAYS.  HBELT 

C  HBELT 

41  IF  (IND.NE.O)  GO  TO  52  HBELT 

K2  =  0  HBELT 

DO  51  JBSJ1 , J2  HBELT 

IF  (NFTPLY(JB) .LE.O)  GO  TO  51  HBELT 

Kl  =  K2  ♦  1  HBELT 

K2  =  K2  ♦  NPTPLY(JB)  HBELT 

DO  50  K=K1 ,K2  HBELT 

KNL  =  KNLO  ♦  K  HBELT 

KI  =  NL(l.KNL)  HBELT 

IF  (IBARd.KI)  .LT.O)  GO  TO  50  HBELT 

KS  =  IBARd.KI)  HBELT 

IF  (KS.GT.100)  KS  =  MOD (KS, 100)  HBELT 

NT  =  IBARd.KI)  HBELT 

NF  =  NTAB (NT+5)  HBELT 

IF  (NF.EQ.O)  GO  TO  43  HBELT 

DO  42  J=  1 ,3  HBELT 

42  T1(J)  =  FR(J.K)  HBELT 

FRl  =  TAB(NF+2)*DABS(T1 (3) )  HBELT 

FR2  =  TAB(NF+4) *DABS(T2 (3) )  HBELT 

IF  (DABS(TKl))  .GT.FR1)  Tl(l)  *  DSIGN(FR1  ,T1  (1) )  HBELT 

IF  (DABS (T1  (2) )  .GT.FR2)  TH2)  *  DSIGN(FR2,T1  (2) )  HBELT 

CALL  MAT31  (E( 1 , 1 ,K) ,T1 ,FCE(1 ,K) )  HBELT 

43  CALL  CROSS  (ZRd.K)  .FCE(l.K)  ,T2)  HBELT 

CALL  MAT31  (D( 1 , 1 ,KS) ,T2 ,T1)  HBELT 

DO  44  J=1 ,3  HBELT 

Ul(J.KS)  =  Ul(J.KS)  ♦  FCE(J.K)  HBELT 

44  U2(J,KS)  »  U2 (J ,XS)  +  T1(J)  HBELT 

50  CONTINUE  HBELT 

51  CONTINUE  HBELT 

52  KNLO  =  KNLO  +  K2  HBELT 

CALL  EL? I ME  (2,38)  HBELT 

RETURN  HBELT 

END  HBELT 


SUBROUT I ME  HBPLAY  HBPLAY 

REV  I I I. 5  10/ 17/85EDGE 

IMPLICIT  REAL* 8  (A-H.0-2)  HBPLAY 

COMMON/CONTRL/  TIME, NSEG , MJNT , HPL , NBLT , NBAG , MVEH , HGRND ,  HBPLAY 

»  NS , NQ , NSD , HFLX , MHRNSS , NWINDF , HJNTF , NPRT ( 36 ) , NPG  PAGE 

COMMOM/CNTSRF/  PL(24,30) ,BELT<20,8) ,TPTS(6,8) ,BD(24,40)  EDGE 

COMMON/SGMNTS/  D(3,3,30) ,WMEG(3,30) ,WMEGD(3,30) ,U1(3,30) ,U2(3,30) .HBPLAY 
«  SEGLP(3,30) , SEGLV(3,30) ,SEGLA(3,30) , HSYM(30)  HBPLAY 

COMMGN/HRNESS/  BAR(15, 100)  .BB(IOO)  .BBDOTUOO)  ,PL0SS(2, 100)  ,  HBPLAY 

*  XL0MG(20) .HTIME (2) , IBAR(5 , 100) ,ML(2 , 100) ,  HBPLAY 

*  NPTSPB(20) ,NPTPLY(20) ,MTHRNS(20) ,NBLTPH(5)  HBPLAY 

THIS  COMMON/TEMPVS/  IS  SHARED  BY  HPTURB,  HBPLAY,  HBELT  AND  HSETC .  HBPLAY 
COMMON/TEMP VS/  B (3 , 3 ,3) . S (3 ,3) ,T (3) ,R(3) , V(3) ,T1 (3) ,T2 (3) ,  HBPLAY 

*  E(3,3,50)  ,ED0T(3,50)  ,FCE(3,50)  , FRO, 50)  ,ZR(3,50)  ,  HBPLAY 

*  TR(3,50) ,U(3 ,50) .PTLOSS (2 ,50) ,BL(50) ,FB(50) ,FP(50) .HBPLAY 

*  OLDBB(IOO) ,RHS(3, 54) ,0(3,3,200) ,IJK(54, 54)  HBPLAY 

IF  (NHRNSS.LE.O)  GO  TO  99  HBPLAY 

HBPLAY 

SAVE  PREVIOUS  NL.BB  AND  PLOSS  ARRAYS.  HBPLAY 

USE  IJK.OLDBB  AND  PTLOSS  AS  TEMP  STORAGE.  HBPLAY 

HBPLAY 

DO  10  1=1,100  HBPLAY 

I JK (1,1)  =  NL ( 1 , I )  HBPLAY 

PTLOSS (1,1)  =  PLOSS (1,1)  HBPLAY 

10  OLDBB(I)  =  BB(I)  HBPLAY 

JNL  =  1  HBPLAY 

J1  =  1  HBPLAY 

K 1  =  1  HBPLAY 

LL  =  0  HBPLAY 

DO  90  NH=1 , NHRNSS  HBPLAY 

IF  ( NBLTPH (NH) . LE . 0 )  GO  TO  90  HBPLAY 

J2  =  J1  ♦  NBLTPH (NH)  -  1  HBPLAY 

DO  80  NB=J1,J2  HBPLAY 

LI  =  LL  HBPLAY 

IF  (NPTSPB(NB) . LE.O)  GO  TO  80  HBPLAY 

K2  =  K1  +  NPTSPB(NB)  -  1  HBPLAY 

KB  =  0  HBPLAY 

DO  30  K=K1 ,K2  i-  HBPLAY 

KB  =  KB  ♦  1  HBPLAY 

HBPLAY 

HERE  K  IS  INDEX  OF  ALL  POINTS  HBPLAY 

KB  IS  INDEX  OF  POINTS  ON  A  SINGLE  BELT  HBPLAY 

LL  IS  INDEX  OF  ALL  POINTS  IN  PLAY  HBPLAY 

JB  IS  INDEX  OF  PREVIOUS  POINT  ON  BELT  IN  PLAY  HBPLAY 

HBPLAY 

KS  =  IABS (IBAR( 1 ,K) )  HBPLAY 

IF  (KS.GT.100)  KS  =  MOD (KS, 100)  HBPLAY 

CALL  D0T31  (D(l , 1 ,KS) ,BAB(4 ,K) ,T1)  HBPLAY 

CALL  DOT31  (D(l , 1 ,KS) ,BAR(7,K) ,T2)  HBPLAY 

DO  11  J= 1 ,3  HBPLAY 


11 


12 


13 


17 


30 


31 


C 

C 

C 

C 


32 


33 


C 

C 

C 

C 


35 


U(J.KB)  =  SEGLP(J.XS)  ♦  T1(J)  ♦  T2(J) 

IF  (X.EQ.X1)  GO  TO  30 
LL  =  LL  +  1 
JJ  =  NL(l.LL) 

JB  =  JJ  -  XI  ♦  1 
DSS  =  0.0 
DO  13  J=1 ,3 

ZR( J ,XB)  =  U(J.XB)  -  U(J, JB) 

DSS  =  DSS  ♦  ZR(J.XB) »»2 
BL (LL)  =  DSQRT(DSS) 

IF  (JJ.EQ.X1  .OR.  IABS(IBAR(1,JJ)) .GT.100)  GO  TO  30 
JS  =  I BAR ( 1 , JJ) 

JE  =  IBAR(2 , JJ) 

IF  (JE.LE.O)  GO  TO  30 

CALL  MAT31  (BD (7 . JE) ,BAR(4 , JJ) ,T2) 

CALL  D0T31  (D(l , 1 ,JS) ,T2,R) 

DPR  =  0.0 
DO  17  J= 1 ,3 

DPR  =  DPR  ♦  R(J)*(ZR(J,KB)/BL(LL)  -  ZR(J,JB)/BL(LL-1) ) 

IF  (DPR. LT. 0.0)  GO  TO  30 

LL  =  LL  -  1 

GO  TO  12 

NL ( 1 , LL+ 1 )  =  X 

L2  =  LI  +  1 

LL  =  LL  ♦  1 

L3  =  LL-1 

DO  31  J=L2,LL 

NL ( 2 , J )  =  NTHRNS (NB) 

IF  (XLONG(NB) .EQ.O.O)  GO  TO  35 

FIRST  TIME  IN  ROUTINE,  SET  INITIAL  BB  ARRAY. 

INPUT  XLONG  MUST  BE  NON-ZERO  TO  TRIGGEB  THIS  TEST. 

XLG  =  0.0 
DO  32  J=L2,L3 

XLG  =  XLG  ♦  BL( J) 

XLG  =  1.0  +  XLONG (NB) /XLG 
DO  33  J=L2,L3 

BB ( J)  =  XLG»BL (J) 

XLONG (NB)  =0.0 
GO  TO  52 

DETERMINE  IF  NEW  NL  ARRAY  IS  DIFFERENT  FROM  PREVIOUS  NL  ARRAY. 
IF  SO,  RECOMPUTE  BB  ELEMENTS  FOR  POINTS  THAT  ARE  DIFFERENT. 


GO  TO  51 


IF  (NL ( 1 ,L2) . EQ. IJK (JNL, 1) ) 

WRITE  (6,62) 

FORMAT  CO  LOGIC  ERROR  IN  SUB  HBPLAY. 
STOP  42 
LTEST  =  0 


PROGRAM  TERMINATED. ') 
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M  =  L2 
N  =  JNL 

IF  (ML ( I . M+l ) - I JK (H+ 1 . 1 ) )  39,37,41 

BB  (If)  =  OLDBB(N) 

PLOSS(l.M)  =  PTLOSS (N,  1 ) 


M  =  M+l 
M  =  N+l 
IF  (M-LL) 


36,51,51 


POINT  M+l  IS  NEW. 


MO  -  M 
NO  =  N 
LTEST  =  1 
M  =  M+l 


MODIFY  NEW  POINT  TO  LIE  IN  BELT  PLANE 


IP1  =  N  -  1 

IF  (N.GT.JNL)  GO  TO  63 


(IS  THIRD  POINT  AVAILABLE  FROM  OLD  POINTS  IN  PLAY?) 

IF  (IJK(N+1 ,1) . EQ.NL(1 ,LL) )  GO  TO  43 
DO  64  1=1,3 

IP  =  IP1  ♦  I  -  1 

(USE  OLD  POINTS  IP  =  M-1,N,N+1  IF  N  >  JNL 

OR  IP  *  N,N+1 ,H+2  IF  N  =  JNL  AND  N+2  EXISTS) 

NI  =  IJK(IP.l) 

NSI=  IABS(IBAR(1 ,NI) ) 

IF  (NSI.GT.100)  NS I  =  MOD(NSI , 100) 

CALL  D0T31  (D(l , 1 ,NSI) ,BAR(4 ,NI) ,T1) 

CALL  D0T31  ( D ( 1 , 1 , NS I ) ,BAR(7,NI) ,T2) 

DO  64  J=1 ,3 

S(J,I)  =  SEGLP ( J ,NSI) +  T1(J)  +  T2(J) 

DO  65  J=1 ,3 

S(J,3)  =  S(J,3)  -  S (J, 2) 

S ( J .2)  =  S (J , 2)  -  S (J ,  1) 

(S(«,l>  IS  POINT  PI  IN  INERTIAL  REFERENCE) 

(S(« ,2)  IS  VECTOR  (P2-P1)  IN  INERTIAL  REFERENCE) 

(S(*,3)  IS  VECTOR  (P3-P2)  IN  INERTIAL  REFERENCE) 

CALL  CROSS  (S(l ,3) ,S(1 ,2) ,T2) 

ABST  =  DSQRT(T2 (1 ) «*2  +  T2(2)«*2  +  T2(3)«»2) 

DO  66  J=1 ,3 

T2 (J)  =  T2 (J) /ABST 

(T2  IS  T,  THE  NORMALIZED  PLANE  VECTOR  IN  INERTIAL  REFERENCE) 
MI  =  NL(1,M) 

MS  =  IABS (IBAR(1 ,MI) ) 

IF  (MS.GT.100)  MS  =  MOD(MS.IOO) 

ME  =  I BAR (2 ,MI) 

CALL  MAT31  (Dd  ,  1  ,MS)  ,T2,T1) 
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( T 1  IS  T  IN  ELLIPSOID  REFERENCE  OF  NEW  POINT  M) 

D1  =  T2 ( 1) *S ( 1 , 1 )  ♦  T2 (2) *S (2 , 1 )  +  T2(3)*S(3, 1) 

D2  =  TI  (1)  *BAR(7,MI)  +  Tl (2) «BAR(8 ,MI)  +  Tl (3) »BAR(9,MI) 

D3  =  T2  ( 1)  *SEGLP  ( 1  ,MS)  +  T2 (2)  »SEGLP (2 ,MS)  +  T2(3)*SEGLP(3,MS) 
DD  =  D1  -  D2  -  D3 

(DD  IS  D,  THE  DISTANCE  OF  ELLIPSOID  CENTER  TO  PLANE) 

CALL  MAT31  (BD ( 16 , ME) ,T1 ,R) 

BX  =  DD/ (Tl ( 1 ) *R( 1)  +  Tl (2) *R(2)  +  T1(3)*R(3)) 

D4  =  Tl (1) * BAR (4, MI)  +  Tl (2) »BAR(5 ,MI)  +  Tl (3) *BAR(6 .MI) 

DO  67  J=  1 ,3 
R(J)  =  BX*R(J) 

(R  IS  S,  THE  CENTER  OF  THE  ELLIPSE) 

V ( J)  =  BAR( J+3 ,MI )  ♦  (DD-D4) «T1 ( J) 

(BAR(J+3,MI)  IS  P,  THE  NEW  POINT  TO  BE  ADDED) 

(V  IS  Q,  THE  PROJECTION  OF  POINT  P  ONTO  THE  PLANE) 

AX  =  DSQRT (  (BX*DD- 1 . 0)  /  (BX*DD-XDY(V,BD(7 ,ME) ,V) )  ) 

DO  68  J=I ,3 

BAR(J+3,MI)  =  R( J)  +  AX* (V( J) -R(J) ) 

( BAR ( J + 3 , MI )  IS  R  =  S  +  A(Q  -  S) ,  Q  EXTENDED  TO  ELLIPSOID) 

GO  TO  43 

POINT  N+l  IS  DROPPED. 

MO  =  M 

NO  =  N 
LTEST  =  1 
N  =  N+ 1 

IF  (NL( 1 ,M+1) -IJK(N+1 , 1) )  40,44,42 

POINTS  NO  TO  N+l  ARE  BEING  REPLACED  WITH  POINTS  MO  TO  M+l. 

SUMBL  =0.0 
DO  45  J=MO,M 
SUMBL  =  SUMBL  +  BL(J) 

SUMPL  =0.0 

SUMBB  =0.0 

DO  46  J=NO,N 

SUMPL  =  SUMPL  +  PTLOSS (J , 1) 

SUMBB  =  SUMBB  +  OLDBB(J) 

RATPL  =  SUMPL/ SUMBL 
RATIO  =  SUMBB/SUMBL 
DO  47  J=MO,M 
PLOSS(l.J)  =  RATPL*BL(J) 

BB(J)  =  RATIO*BL ( J) 

GO  TO  38 
JNL  =  N+l 

IF  (LTEST. EQ.O)  GO  TO  79 

PRINT  NEW  POINT  ARRAY  IF  DIFFERENT. 
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52  NPTS  =  LL  -  LI  HBPLAY 

USEC  =  1000.0*TIME  HBPLAY 

WRITE  (6,53)  USEC, NH.NB, NPTS, NTHRNS( MB)  HBPLAY 

53  FORMAT  (’0  HBPLAY  TIME  =\F10.3,’  MSEC.  NH.NB, NPTS  NT=’,4I6)  HBPLAY 

WRITE  (6,54)  (NL( 1 , J) , J=L2 ,LL)  HBPLAY 

54  FORMAT  (’  NL(1) =’, 1518/ (8X, 1518) )  HBPLAY 

WRITE  (6,55)  (BB(J) , J=L2 ,L3)  HBPLAY 

55  FORMAT  (’  BB  = ’ ,6X, 14F8 . 3/ (6X, 15F8. 3) )  HBPLAY 

79  K1  s  K2  +  1  HBPLAY 

80  NPTPLY(NB)  =  LL  -  LI  HBPLAY 

J1  =  J2  +  1  HBPLAY 

90  CONTINUE  HBPLAY 

99  RETURN  HBPLAY 

END  HBPLAY 


SUBROUT I ME  HEDING  (LINES.LPP) 

REV  IV 

IMPLICIT  REAL* 8  (A-H.O-Z) 

COMMOM/ COMTRL /  TIME , NSEG, NJNT , NPL , MBLT , MBAG , HVEH , MGRMD , 


HEDING 

02/01/88MISD0T 

HEDING 

HEDING 


*  NS , NQ , NSD , NFLX , NHRNSS , NWINDF , NJNTF , NPRT ( 36 ) , NPG  PAGE 
COMMON/ JBARTZ/  MNPL(  30),MNBLT(  8) , MNSEG(  30) ,MNBAG(  6) ,  HEDING 

*  MPL(3 ,5,30) , MBLT (3 ,5,8) ,MSEG(3 ,5 ,30) ,MBAG(3, 10,6) ,  ^HEDING 

*  NTPL (  5,30) , NTBLT (  5,8),NTSEG(  5,30)  HEDING 

COMMON/TITLES/  DATE(3) ,C0MENT(40) ,VPSTTL(20) ,BDYTTL(5) ,  HEDING 

»  BLTTTL(5,8) ,PLTTL(5,30) ,BAGTTL(5,6) ,SEG(30) ,  HEDING 

»  J0INT(30) ,CGS(30) , JS(30)  HEDING 

REAL  DATE , COMENT , VPSTTL , BDYTTL , BLTTTL , PLTTL , BAGTTL , SEG, JOINT  HEDING 

LOGICAL*!  CGS.JS  HEDING 

COMMON/FORCES/PSF(7,70) ,BSF(4,20) ,SSF(10,40) ,BAGSF(3,20) ,  NCFORC 

»  PRJNT (7,30) , NPANEL ( 5 ) , NPSF , NBSF , NSSF , NBGSF  HEDING 

COMMON/ CNSNTS/  PI .RADIAN, G, THIRD, EPS(24) ,  HEDING 

»  UNITL,UNITM,UNITT,GRAVTY(3) .TWOPI  TWOPI 

COMMON/RSAVE/  XSG(3 . 20 , 3) .DPMI (3 , 3 ,30) ,LPMI  (30) ,  ATBIII 

*  NSG(9) ,MSG(20,9) ,MCG,MCGIN(24 ,5) ,KREF(20,9)  TTHKREF 

COMMON/ DAMPER/  APSDM(3,20) ,APSDN(3,20) ,ASD(5,20) ,MSDM(20) ,MSDN( 20) HEDING 
COMMON/ HRNESS/  BAR ( 1 5 , 1 00) , BB ( 100) , BBDOT ( 100) , PLOSS ( 2 , 100) ,  HEDING 

»  XLONG(20) , HTIME (2) , IBAR(5 , 100) ,HL(2 , 100) ,  HEDING 

*  NPTSPB(20) ,NPTPLY(20) ,NTHRNS(20) ,NBLTPH(5)  HEDING 

NOTE:  SUBROUTINES  POSTPR  &  HEDING  SHARE  THIS  COMMON/TEMPVS/ .  HEDING 

SEE  COMMENT  IN  POSTPR  ABOUT  FIRST  DIMENSION  OF  PLDATA.  HEDING 

REAL  HEAD, PHED, BLANK, PLDATA, USEC , ZTTH , AHED , AHEAD, GHED.ZZZ  PLTINC 

COMMON/TEMP VS/  TDATA(14,65) ,HEAD(20) ,N0PL(150) ,M0PL(150) ,  CHGIII 

*  M1PL( 150) .PLDATA (97, 20) ,USEC(45) ,ZZZ(1000,25) ,ZTTH( 14 .45 ,65)  MISDOT 

LOGICAL  LOLD  ,  LNEW  HEDING 

DIMENSION  PHED (5) ,HEDJ(4,2) ,HEADJJ(4,2) ,HEADR(20)  TTHKREF 

DATA  HEDJ/8HIPIN  FL , 8HEXURE  A.8HZIMUTH  , 8HT0RSI0N  ,  HEDING 

»  BHIEULER  , 8HPREC .  N.8HUTATI0N  ,8H  SPIN  /  HEDING 

DIMENSION  AHED (5, 2) ,AHEAD(5,20) , GHED ( 2 )  ACCEL 

DATA  AHED/4H  IN  ,4H  ,4H  REF , 4HEREN , 4HCE  ,  ACCEL 

«  4H  AC , 4HCELE , 4HR0ME , 4HTER  ,4H  /  ACCEL 

DATA  GHED/ 4H(0G) ,4H(1G)/  ACCEL 

DATA  BLANK/4H  /  HEDING 

DATA  PHED/4HSPRF , 4HPNL 1 , 4HPNL2 , 4HPNL3 , 4HPNL4/  HEDING 

NPRT4  =  NPRT (4)  ♦  4  HEDING 

IF  (NPRT4.LE.0  .OR.  NPRT4.GT.8)  STOP  40  HEDING 

GO  TO  (11,11,82,12,12,11,11,12)  ,  NPRT4  HEDING 

11  LOLD  =  .FALSE.  HEDING 

LNEW  =  .TRUE.  HEDING 

GO  TO  13  HEDING 

12  LOLD  *  .TRUE.  HEDING 

LNEW  3  .FALSE.  HEDING 

13  MT  =  20  HEDING 

NLINES  =  MOD (LINES- 1,LPP)+1  HEDING 

XPAGE  =  0.01»FLOAT(  (LINES  ♦  LPP-D/LPP)  HEDING 

HEDING 


C  NOTE:  MT  WILL  BE  THE  PAGE  OR  OUTPUT  UNIT  COUNTER  HEDING 

C  NT  WILL  BE  THE  ACTUAL  OUTPUT  UNIT  NUMBER  HEDING 

C  IT  WILL  BE  THE  INDEX  TO  THE  DATA  ARRAY  HEDING 

C  NLINES  WILL  BE  THE  NUMBER  OF  LINES  TO  BE  PRINTED  HEDING 

C  HEDING 

C  HEDING 

C  EVERY  LPP  LINES  PRINT  HEADINGS  FOR  9  TYPES  OF  OUTPUT  ABOVE.  WINDOP 

C  HEDING 

DO  20  K= 1 ,9  WINDOP 

IF  (NSG(K) .LE.O)  GO  TO  20  HEDING 

KSG  =  NSG(K)  HEDING 

IF  (K.EQ.9)  GO  TO  455  WINDOP 

J3  =3  HEDING 

IF  (K.EQ.7)  J3  =  2  HEDING 

DO  19  Jl= 1 , KSG, J3  HEDING 

MT  =  MT  ♦  1  HEDING 

NT  =  MT  HEDING 

IF  (LNEW)  NT  =  6  HEDING 

IT  =  MT  -  20  HEDING 

PAGE  =  FLOAT (MT)  +  XPAGE  HEDING 

C  ?  &  E  PRINTER  CARRIAGE  CONTROL  PECONV 

CALL  CARCON(NT.l)  PECONV 

IF  (NT.EQ.6)  WRITE (NT, 121)  DATE, BLANK, NPG  PAGE 

IF  (NT.NE.6)  WRITE(NT, 121)  DATE  PAGE 

IF  (NT.EQ.6)  NPG=NPG* 1  PAGE 

WRITE  (NT, 21)  COMENT , PAGE , VPSTTL , BDYTTL  PAGE 

IF  (K.EQ.l)  WRITE  (NT. 22)  TTHKREF 

IF  (K.EQ.2)  WRITE  (NT. 23)  UNITL.UNITT  TTHKREF 

IF  (K.EQ.3)  WRITE  (NT, 24)  UNITL  TTHKREF 

IF  (K.EQ.4)  WRITE  (NT, 25)  UNITT  TTHKREF 

IF  (K.EQ.5)  WRITE  (NT, 26)  UNITT  TTHKREF 

IF  (K.EQ.6)  WRITE  (NT, 27)  TTHKREF 

IF  (K.EQ.7)  WRITE  (NT, 28)  HEDING 

IF  (K.EQ.8)  WRITE (NT, 200)  UNITM  TTHKREF 

J2  =  MIN0(J1+J3-1 ,KSG)  HEDING 

DO  14  J=J1 , J2  HEDING 

KK  =  MSG(J,K)  HEDING 

HEAD(J)  =  SEG(IABS(KK) )  ACCEL 

IF  ((K.LT.7) .OR. (K.EQ.8))  GO  TO  214  TTHKREF 

KK  =  IABS(KK)  HEDING 

HEAD ( J)  =  JOINT (KK)  HEDING 

JJ2  =  J-Jl+1  HEDING 

K2  =  1  HEDING 

IF  (MSG(J,K) .LT.O)  K2  =  2  HEDING 

DO  35  Kl=l ,4  HEDING 

35  HEADJJ (K1 , JJ2)  =  HEDJ(K1,K2)  HEDING 

GO  TO  14  TTHKREF 

214  IF  (MSG(J.K) .LT.O)  GOTO  302  ACCEL 

IF  (KREF(J.K) .EQ.O)  HEADR(J) =SEG(NVEH)  ACCEL 

IF  (K.EQ.8)  HEADR(J) =SEG(NGRND)  TTHKREF 


o  o  o 


IF  (K.EQ.l  .OR.  K.EQ.4)  HEADR(J) »SEG(KK) 

IF  (KREF(J.K) .NE.O)  HEADR(J) =SEG(KREF(J ,K) ) 

DO  301  11=1,5 

301  AHEAD (I I , J) =AHED( II , 1) 

AHEAD ( 2 , J ) =  HEADR ( J ) 

GOTO  14 

302  HEADR(J) =SEG(IA£S (XK) ) 

DO  303  11=1,4 

303  AHEAD (II ,J)=AHED(II ,2) 

AHEAD (5 , J) =GHED (KREF ( J , K) + 1 ) 

14  CONTI HUE 

IF  (K.LE.3)  WRITE  (NT, 29)  (BLANK , (XSG(I , J ,K) , 1= 1 ,3) , J=J1 , J2) 
IF  (K.LE.6)  WRITE  (NT, 30)  (BLANK, HSG(J, K) ,HEAD(J) ,J=J1 ,J2) 

IF  (K.EQ.8)  WRITE  (NT, 30)  (BLANK, MSG(J, K) ,HEAD(J) ,J=J1 ,J2) 

IF  (K.LE.6  .OR.  K.EQ.8)  WRITE  (NT, 230) 

*  (BLANK, (AHEAD (II ,J) ,11=1,5) ,J=J1,J2) 

IF  ((K.LE.5) .OR. (K.EQ.8))  WRITE  (NT, 31)  (BLANK, J*J1 ,J2) 

IF  (K.EQ.6)  WRITE  (NT, 32)  (BLANK, J=J1 ,J2) 

IF  ((K.LT.7) .OR. (K.EQ.8))  GOTO  15 
WRITE  (NT, 33)  (BLANK, MSG(J, X) ,HEAD(J) ,J=J1 ,J2) 

WRITE  (NT, 36)  (BLANK .UNITL ,UNITM,J=J1 ,J2) 

WRITE  (NT, 37)  (BLANK, (HEADJJ (K1 , J) ,Kl=l ,4) , J=1 , JJ2) 

15  WRITE  (NT, 38) 

IF  ( . NOT . LNEW)  GO  TO  19 
IF  (K.EQ.7)  GO  TO  17 
JJ  =  4«  (J2-J1  +  1) 

DO  16  1=1 .NLINES 

16  WRITE  (NT, 39)  USEC(I) , (ZTTH(J, I , IT) , J=I ,  JJ) 

GO  TO  19 

17  JJ  =  7»  (J2--J1  +  1) 

DO  18  1=1, NLINES 

18  WRITE  (NT, 40)  DSEC (I) , (ZTTH( J , I , IT) , J= l , JJ) 

19  CONTINUE 
GO  TO  20 

PRINT  HEADING  FOR  JOINT  FORCES  &  TORQUES 

455  CONTINUE 

DO  860  11=1 ,KSG 
IF (KREF (I I ,K) . EQ.O)  KRF  =  NVEH 
IF (KREF (II ,K) . NE.O)  KRF  =  KREF (II ,K) 

JRF  =  MSG(II ,9) 

Iff  =  MT  ♦  1 
NT  =  MT 

IF  (LNEW)  NT  =  6 
C  P  &  E  CARRIAGE  CONTROL 
CALL  CARCON(NT.l) 

IT  =  1IT  -  20 

PAGE  =  FLOAT  (iff)  ♦  XPAGE 

IF  (NT. EQ.O)  WRITE (NT, 121)  DATE , BLANK , NPG 
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IF  (NT.NE.6)  WRITE(NT,121)  DATE 

IF  (NT.EQ.6)  NPG=NPG+ 1 

WRITE  (NT, 21)  COMENT , PAGE , VPSTTL , BDYTTL 

WRITE  (NT, 850)  JOINT(JRF) ,SEG(JRF+1) , SEG(KRF) 

WRITE  (NT, 38) 

WRITE  (NT, 851)  UNITM,UNITL,UNITM 
WRITE  (NT, 852) 

WRITE  (NT, 38) 

IF  ( . NOT . LNEW)  GO  TO  857 
DO  858  JK= I , NLINES 

WRITE  (NT, 856)  USEC(JK) , (ZTTH(J.JK.IT) ,J=1 ,6) 

858  CONTINUE 
857  CONTINUE 

850  FORMAT (’  ’/47X, 

»  A4,’  JOINT  FORCES  &  TORQUES  ON  \A4,’  IN  \A4,'  REFERENCE1) 

851  FORMAT (4X.4HTIME.7X, 13HJ0INT  FORCE  (,A4,7H  10**2), 10X, 

• 14HJ0INT  TORQUE  ( ,A4 , 1H- , A4 ,7H  10**2)) 

852  FORMAT (3X,0H( MSEC) ,8X, 1HX.8X, 1HT.8X, 1HZ, 14X, 1HX, 11X, 1HY, 11X, 1HZ) 
856  FORMAT(F9.3,3X,3F9.3,3X,3(2X,D10.3) ) 

860  CONTINUE 

20  CONTINUE 

121  FORMAT ( ’ 1 ‘ , 18X , ’ DATE : ’ ,3X,4A4 ,80X, ’PAGE* ,15) 

21  FORMAT (8X, ’RUN  DESCRIPTION: ’ .3X.20A4/27X.20A4, ’PAGE: ’ ,F6. 2/ 

«  3X, ’VEHICLE  DECELERATION: ’ .3X.20A4/ 

*  llX.’CRASH  VICTIM: ’ ,3X,5A4  ) 

22  FORMAT (’  '47X, 

*  ’POINT  TOTAL  ACCELERATION  (G”S)’/) 

23  FORMAT (’  '47X, 

•’POINT  REL.  VELOCITY  (’ ,A4, ’/’ ,A4, ’) ’/) 

24  FORMAT ( ’  '47X, 

» ’POINT  REL.  LINEAR  DISPLACEMENT  (’,A4,’)’/) 

25  FORMAT (’  ’/47X, 

» ’ SEGMENT  ANGULAR  ACCELERATION  (REV/ ’ , A4 , ’ «*2) ’ /) 

26  FORMAT (’  ’/47X, 

•’SEGMENT  REL.  ANGULAR  VELOCITY  (REV/ ’ ,A4 , ’ ) ’ /) 

27  FORMAT (’  ’/47X, 

»  ’SEGMENT  REL.  ANGULAR  DISPLACEMENT  (DEG)’/) 

28  FORMAT (’  ’/47X, ’JOINT  PARAMETERS’/) 

200  FORMAT  ( ’  ’ /47X,  ’  SEGMENT  WIND  FORCE  (\A4,’)’/) 

29  FORMAT (9X, 3 (A4.3X, ’POINT  ( ’ ,F8 . 2 , ’ , ' ,F6 . 2, ’ , ’ ,F6. 2 , ’ )  ON  ’)  ) 

30  FORMAT (’  ' ,3(A4,9X, ’SEGMENT  NO. ’ ,13, ’  -  ’,A4,5X)  ) 

230  FORMAT ( ’  TIME  ’ . 3 (A4 ,9X, 5A4 ,6X) ) 

31  FORMAT (’  (MSEC) ’ ,3(A4,5X, ’X’ ,8X, ’Y’ ,8X, ’Z’ ,7X, ’RES’ , IX)  ) 

32  FORMAT (’  (MSEC) ’ ,3 (A4 ,4X, ’YAW’ ,5X, ’PITCH’ , 5X, ’ROLL’ ,5X, ’RES  ’) 

33  FORMAT (9X, 2 (A1 ,21X, ’JOINT  NO. ’ ,13, ’  -  ’.A4.20X)  ) 

36  FORMAT (’  TIME  ’, 2 (A1 , ’STATE ’, 5X, ’JOINT  ANGLES  (DEG) ’ ,8X, 

*  ’TOTAL  TORQUE  (’,2A4,’)  ’)  ) 

37  FORMAT (’  (MSEC) ’, 2 (A1 ,4A8 , 4X, ’ SPRING  VISCOUS  RES.  ’)  ) 

38  FORMAT (IX) 

39  FORMAT (F9 . 3 , 3 (3X , 4F9 . 3)  ) 
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40  FORMAT (F9.3,2(F5.0, 3F9 . 3 , 2X , 3F9 . 3 ) )  HEDING 

C  ATBIII 

C  PRINT  BODY  PROPERTIES  CONTROLLED  BY  H.10  CARDS  WINDOP 

C  ATBIII 

IF  (MCG.EQ.O)  GO  TO  131  ATBIII 

DO  130  NCG= 1 , MCG  ATBIII 

MT  =  MT  +1  ATBIII 

NT  =  MT  ATBIII 

IF  ( LNEW)  NT  =  6  ATBIII 

C  P  &  E  CARRIAGE  CONTROL  P^CONV 

CALL  CARCON(NT.l)  PECONV 

IT  =  MT  -  20  ATBIII 

PAGE  =  FLOAT (MT)  +  XPAGE  ATBIII 

IF  (NT.EQ.6)  WRITE (NT, 121)  DATE , BLANK , NPG  PAGE 

IF  (NT.NE.6)  WRITE(NT, 121)  DATE  PAGE 

IF  (NT.EQ.6)  NPG=NPG+ 1  PAGE 

WRITE  (NT, 21)  COMENT , PAGE , VPSTTL , BDYTTL  PAGE 

M  =  MCGIN ( 1 , NCG)  ATBIII 

WRITE  (NT, 132)  M,SEG(M)  ATBIII 

N  =  MCGIN (2, NCG)  ATBIII 

WRITE  (NT, 133)  (MCGINU+2 ,NCG) . 1=1 ,N)  ATBIII 

WRITE  (NT, 38)  ATBIII 

WRITE  (NT, 134)  UNITL , ONITM , ONITT , UNITL , ONITM, UNITT , ONITM, UNITL  KINETIC 

WRITE  (NT, 38)  ATBIII 

IF  (.NOT. LNEW)  GO  TO  130  ATBIII 

DO  129  1=1 , NLINES  ATBIII 

129  WRITE  (NT, 135)  USEC(I) , (ZTTH(J,I ,IT) , J=1 , 12)  KINETIC 

130  CONTINUE  ATBIII 

131  CONTINUE  ATBIII 

132  FORMAT ('  ’ .47X.39HB0DY  PROPERTIES  -  REFERENCE  SEGMENT  NO.,  TTHKREF 

«  13, 2H  ( ,A4 , 1H)  )  ATBIII 

133  FORMAT (15X. 21 HI NCLUDED  SEGMENT  NOS:, 2013)  ATBIII 

134  FORMAT ( 14X, 17HCENTER  OF  GRAVITY, 13X, 15HLINEAB  MOMENTUM. 17X,  KINETIC 

«  18 HANGUL Afi  MOMENTUM, 18X, 14HKINETIC  ENERGY/  KINETIC 

»  4X , 4HTIME , 1 IX , 1H( , A4 , 1H) , 2 IX , 1H ( , A4 , 1H- , A4 , 1H) , 19X,  KINETIC 

•  1H(,A4,1H-,A4.1H-,A4,1H) , 20X, 1H( , A4 , 1H- ,A4 , 1H) /  MISC 

•  3X.6H(MSEC) ,5X, 1HX.7X, 1HY.7X, 1HZ,  KINETIC 

•  2( 10X, 1HX, 10X, 1HY, 10X, 1HZ) ,6X,0HL1NEAR,5X,  KINETIC 

•  7 HANGUL AR , 5X , 5HT0TAL)  KINETIC 

135  FORMAT (F9. 3, 3F6. 3, 9 (IX, DIO. 3) )  KINETIC 

C  HEDING 

C  PLANE  FORCES  HEADINGS  HEDING 

C  HEDING 

MPSF  =  0  HEDING 

IF  (NPL.EQ.O)  GO  TO  52  HEDING 

IF  (NPRT(18) .EQ. 1.0R.NPRT(18) .EQ.7)  GO  TO  52  VARTTH 

IF  (NPRT (18) . EQ. 10 . OR. NPRT ( 18) .EQ. 1 1)  GO  TO  52  VARTTH 

IF  (NPRT(18) .GE. 14)  GO  TO  52  VARTTH 

DO  42  J=1,NPL  HEDING 

IF  (MNPL(J) .EQ.O)  GO  TO  42  HEDING 


KPL  =  lOIPL(J)  HEDING 

DO  41  1=1, KPL  HEDIHG 

MPSF  =  MPSF+1  HEDIHG 

NOPL(MPSF)  =  J  HEDIHG 

IF  (MPL(3,I,J) .LT.O)  Ml PL (MPSF)  =  MPL(2,I,J)  CHGIII 

IF  (MPL(3,1 ,J) .GE.O)  MIPL(MPSF)  =  MPL(l.I.J)  CHGIII 

41  1I0PL()(PSF)  =  MPL (2 , 1 ,  J)  HEDIHG 

42  CONTI HUE  HEDIHG 

IF  (MPSF.EQ.O)  GO  TO  52  HEDING 

DO  44  Jl= 1 .MPSF , 2  HEDIHG 

J2  =  MINO (Jl+1 , MPSF)  HEDING 

MT  =  MT  +  1  HEDIHG 

NT  =  ITT  HEDING 

IF  (LNEW)  NT  *  6  HEDIHG 

P  &  E  CAPRI AGE  CONTROL  PECONV 

CALL  CARCOH(HT.l)  PECONV 

IT  =  MT  -  20  HEDIHG 

PAGE  =  FLOAT (MT)  ♦  XPAGE  HEDING 

IF  (NT.EQ.6)  WRITE (NT, 121)  DATE , BLANK , HPG  PAGE 

IF  (NT. HE. 6)  WRITE(NT, 121)  DATE  PAGE 

IF  (NT.EQ.6)  NPG=NPG+ 1  PAGE 

WRITE  (NT, 21)  COMENT , PAGE , VPSTTL , BDYTTL  PAGE 

WRITE  (NT, 45)  HEDING 

N1  =  NOPL(Jl)  HEDING 

N2  =  NOPL (J2)  HEDING 

Ml  =  MOPL(Jl)  HEDING 

M2  =  M0PL(J2)  HEDING 

MM1  =  M1PL(J1)  CHGIII 

MM2  =  M1PL ( J2)  CHGIII 

IF  (J1.EQ.J2)  WRITE  (NT, 46)  HEDING 

«  BLANK, Ml, (  PLTTL(I.Nl) ,1=1,5) , Ml, SEG(Ml)  HEDING 

IF  (J1.NE.J2)  WRITE  (NT, 46)  HEDING 

»  BLANK,N1,(  PLTTL(I.Nl) ,1=1,5) , Ml, SEG(Ml) ,  HEDING 

*  BLANK, N2, (  PLTTL(I,N2) ,1=1,5) , M2, SEG(M2)  HEDING 

WRITE  (NT, 47)  (BLANK, UNITL, J=J1 ,J2)  HEDING 

IF  (Jl.EQ.J2)  WRITE  (NT, 48)  BLANK, SEG(MMl)  CHGIII 

IF  (J1.NE.J2)  WRITE  (NT, 448}  BLANK, SEG(MMl) .BLANK, SEG(MM2)  CHGIII 

WRITE  (NT. 49)  (BLANK, UNITL, UHITM.UNITM, UNITM, J=J1 ,J2)  HEDING 

WRITE  (NT, 38)  HEDING 

IF  ( . NOT . LNE W)  GO  TO  44  HEDING 

JJ  =  7*  ( J2-J1  + 1)  HEDING 

DO  43  1=1 .NLINES  HEDING 

43  WRITE  (NT, 50)  USEC(I) , (ZTTH(J,I ,IT) ,J=1 ,JJ)  HEDING 

44  CONTINUE  HEDING 

45  FORMAT ( 2 7X, ’CONTACT  FORCES  -  SEGMENT  PANELS  VS.  SEGMENTS’  )  CHGIII 

46  FORMAT ( ’  ’/8X,2(A4,’  PANEL’, 13,'  (\5A4,’)  VS.  SEGMENT’, 13,  HEDING 

»  ’  (’,A4,’)  ’)  )  HEDING 

47  FORMAT (’  ’ ,8X, A4 , ’DEFL-  NORMAL  FRICTION  RESULTANT  CONTACT  LOCATHED I NG 

» ION  ( ’ , A4 , ’ ) ’ , A2 , ’ DEFL-  NORMAL  FRICTION  RESULTANT  CONTACT  LOCATHEDING 
•ION  (’ ,A4, ’) ’)  HEDIHG 
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48  FORMAT {’  TIME’ ,  A4, ’ECTION  FORCE  FORCE  FORCE 

• . ’  REFERENCE) ’  ) 

448  FORMAT (’  TIME’ ,A4 , ’ECTION  FORCE  FORCE  FORCE 

REFERENCE) ' ,2X,A4,’ ECTION  FORCE  FORCE  FORCE 
« , ’  REFEREHCE) ’  ) 

49  FORMAT ( ’  (MSEC) ’ , 2 (A3 , ’ ( ’ , A4 , ’ ) ’ , 2X, ’ ( ’ , A4 , ’ ) ’ ,4X, ’ ( ’ , A4 

«  ’ (’ ,A4,  ’)  X  T  Z  ’)  ) 

50  FORMAT (F9 .3,2 (F9 . 3 ,3F9 . 2 , 3F8 .3)  ) 

51  FORMAT (3X, ’ (MSEC) ' ,4 (A1 ,9X, ’X’ ,8X, ' Y’ ,8X, ’Z’ ,1X)) 

BELT  FORCES  HEADINGS 

52  MBSF  =  0 

IF  (NPRT (18) . EQ . 2 . OR. NPRT (18) . GE. 13)  GO  TO  83 

IF  ( NPRT (18) . GE . 7 . AND . NPRT ( 1 8 ) . LE . 9 )  GO  TO  83 

IF  (NBLT.EQ.O)  GO  TO  83 

DO  54  J  = 1 , NBLT 

IF  (MNBLT(J) .EQ.O)  GO  TO  54 

MBSF  =  MBSF+1 

NOPL(MBSF)  =  J 

MOPL(MBSF)  =  MBLT (2 , 1 , J) 
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54  CONTINUE 

HEDING 

IF  (MBSF. EQ.O)  GO  TO  83 

HEDING 

wSmmm 

DO  56  J 1 = 1 , MBSF, 2 

HEDING 

J2  =  MIN0(J1+1 ,MBSF) 

HEDING 

mm 

MT  =  MT  ♦  I 

HEDING 

f 

NT  =  MT 

HEDING 

IF  ( LNEW)  NT  =  6 

HEDING 

P  &  E  CARRIAGE  CONTROL 
CALL  CARCON(NT.l) 

IT  =  MT  -  20 

PAGE  =  FLOAT (MT)  +  XPAGE 

IF  (NT.EQ.6)  WRITE (NT, 121)  DATE , BLANK , NPG 

IF  (NT.NE.6)  WRITE(NT , 121)  DATE 

IF  (NT.EQ.6)  NPG=NPG+ 1 

WRITE  (NT .21)  COMENT , PAGE , VPSTTL , BDYTTL 

WRITE  (NT. 57) 

N1  =  NOPL(Jl) 

N2  =  NOPL ( J2) 

Ml  =  MOPL(Jl) 

M2  =  MOPL ( J2) 

IF  (J1.EQ.J2)  WRITE  (NT, 58) 

*  BLANK, Nl, (BLTTTL(I.Nl) .1=1,5) ,M1,SEG(M1) 

IF  (J1.NE.J2)  WRITE  (NT, 58) 

*  BLANK, Nl, (BLTTTL(I,N1) ,1=1,5) ,M1,SEG(M1) . 

*  BLANK, N2,  (BLTTTLU  ,N2)  ,1  =  1,5)  ,M2,SEG(M2) 
WRITE  (NT, 59)  (BLANK ,J=J1 ,J2) 

WRITE  (NT, 60)  (BLANK ,J=J1 ,J2) 

WRITE  ( NT , 6 1 )  (BLANK, UNITL,UNITL,UNITM,UNITL,UNITL,UNITM, J 
WRITE  (NT, 38) 
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17  ( . HOT . LMEW)  00  TO  56  HEDING 

JJ  =  4» (J2-J1+1)  HEDING 

DO  55  1=1 .KLINES  HEDIMQ 

55  WRITE  (NT, 82)  DSEC (I) , (ZTTH(J , I , IT) , J= 1 , JJ)  HEDIMQ 

56  CONTINUE  HEDINQ 

57  FORMAT  CO’ ,26X,' CONTACT  FORCES  -  BELTS  VS.  SEGMENTS’)  HEDINQ 

58  FORMAT  (’  ’,7X,2(A4,’  BELT’,13,'  (’^4,’)  VS.  SEGMENT’  ,  13 ,  HEDINQ 

«  ’  C.A4,')  ')  )  HEDINQ 

59  FORMAT (’  ' ,2X,2 (A4 . 1 IX, ' ANCHOR  POINT  A’ , 14X, ’ANCHOR  POINT  B’))HEDING 

60  F0RMAT(4X, ’TIME', 2(A4,5X, 'STRAIN* ,7X, ’FORCE’, 12X.  HEDINQ 

*  ' STRAIN ',7X,’ FORCE’,  3X)  )  HEDINQ 

61  FORMAT (3X, ’ (MSEC) ' ,2 (A4 ,2X, ' ( ’ ,A4 , , A4 , ’ ) ’ ,4X, ’ C ,A4.’) ’ ,9X,  HEDING 

»  ' ( ' , A4 , ’ / ’ , A4 , ’ ) ' , 4X , ’ ( ’ , A4 , ’ ) ’ , 3X)  )  HEDING 

62  FORMAT (F9. 3, 4 (FI 5. 6, FI 2. 2, 3X)  )  HEDINQ 

HEDINQ 

HARNESS  BELT  ENDPOINTS  FORCES  HEADINGS  HEDING 

HEDING 

83  IF  (NHRNSS.LE.O)  GO  TO  91  HEDINQ 

MBSF  =  0  HEDINQ 

IF  (NPRT(18) . EQ. 3 . OR. MPRT ( 18) . EQ. 11)  GO  TO  91  VARTTH 

IF  (NPRT(18) . EQ . 9 .OR. NPRT( 18) .EQ.6)  GO  TO  91  VARTTH 

IF  (NPRT(18) .EQ. 13.0R.NPBT(18) .EQ. 14)  GO  TO  91  VARTTH 

IF  (NPRT(18) .QE.16)  GO  TO  91  VARTTH 

J1  =  1  HEDING 

K1  =  1  HEDINQ 

DO  85  1=1 .NHRNSS  HEDINQ 

IF  (NBLTPH(I) .LE.O)  GO  TO  85  HEDINQ 

J2  =  J1  +  NBLTPH ( I )  -  1  HEDING 

DO  84  J=J1,J2  HEDINQ 

MBSF  =  MBSF  +  1  HEDINQ 

IF  (NPTSPB(J) .LE.O)  GO  TO  84  HEDINQ 

K2  =  K1  +  NPTSPB(J)  -  1  HEDINQ 

NOPL (2»MBSF- 1 )  =  J  HEDINQ 

NGPL(2»MBSF  )  =  I  HEDINQ 

MOPL (2*MBSF- 1 )  =  K1  HEDINQ 

M0PL(2*MBSF  )  =  K2  HEDINQ 

K1  =  K2  +  1  HEDINQ 

84  CONTINUE  HEDINQ 

J1  =  J2  ♦  1  HEDINQ 

85  CONTINUE  HEDINQ 

DO  87  J 1 = 1 , MBSF, 2  HEDING 

J2  =  MINO (J1+ 1 ,MBSF)  HEDINQ 

MT  =  MT  +  1  HEDINQ 

NT  =  MT  HEDING 

IF  (LNEW)  NT  =  6  HEDING 

P  &  E  CARRIAGE  CONTROL  PECONV 

CALL  CARCON(NT.l)  PECONV 

IT  =  MT  -  20  HEDING 

PAGE  =  FLOAT (MT)  ♦  XPAGE  HEDINQ 

IF  (NT. EC. 6)  WRITE(NT, 121)  DATE , BLANK , NPQ  PAGE 


IF  (NT.NE.6)  WHITE (MT, 121)  DATE  PAGE 

IF  (NT.EQ.6)  NPG=NPG+ 1  PAGE 

WRITE  (NT, 21)  COMENT , PAGE , VPSTTL , BDYTTL  PAGE 

WRITE  (NT, 88)  HEDING 

WRITE  (NT, 89)  (BLANK, NOPL(2»J-l) ,NOPL(2*J) ,J*J1 ,J2)  HEDING 

WRITE  (NT, 90)  (BLANK, M0PL(2»J-1) ,MOPL(2»J) ,J«J1 ,J2)  HEDING 

WRITE  (NT, 60)  (BLANK, J=J1 ,J2)  HEDING 

WRITE  (NT, 61)  (BLANK, UNITL,UNITL,UNITM,UMITL,UMITL.UNITM,J«J1 ,J2)  HEDING 
WRITE  (NT, 38)  HEDING 

IF  ( . NOT . LNEW)  GO  TO  87  HEDING 

JJ  =  4» (J2-J1+ 1 )  HEDING 

DO  86  Is 1 , NLINES  HEDING 

86  WRITE  (NT. 62)  USEC(I) , (ZTTH(J,I . IT) , J= 1 ,JJ)  HEDING 

87  CONTINUE  HEDING 

88  FORMAT ( ’0’ ,26X, ’HARNESS  SYSTEM  BELT  ENDPOINT  FORCES’)  HEDING 

89  FORMAT (9X, 2 (A4 , 1 IX, ' BELT  NO. ’,14,’  OF  HARNESS  MO.’,I3,15X))  HEDING 

90  FORMAT (9X. 2 (A4.6X, ’POINT  NO. ’ ,15, 16X, ‘POINT  NO.’,I5,6X))  HEDING 

HEDING 

SPRING  DAMPER  FORCES  HEADINGS  HEDING 

HEDING 

91  IF  (NSD.LE.O)  GO  TO  63  HEDING 

IF  (NPRT(18) . EQ. 4 .OR.NPRT ( 18) .EQ.9)  GO  TO  63  VARTTH 

IF  (NPBT(18) .GE.12)  GO  TO  63  VARTTH 

DO  94  Jl  =  1 ,NSD ,4  HEDING 

J2  =  MINO (Jl+3 ,NSD)  HEDING 

MT  =  MT  ♦  1  HEDING 

NT  =  MT  HEDING 

IF  (LNEW)  NT  =  6  HEDING 

P  &  E  CARRIAGE  CONTROL  PECOHV 

CALL  CARCON(NT.l)  PECONV 

IT  =  MT  -  20  HEDING 

PAGE  =  FLOAT (MT)  ♦  XPAGE  HEDING 

TF  'MT.EQ.6)  WRITE(NT, 121)  DATE .BLANK, NPG  PAGE 

. F  (NT.NE.6)  WRITE (NT, 121)  DATE  PAGE 

IF  (NT.EQ.6)  NPG=NPG* 1  PAGE 

WRITE  (NT, 21)  COMENT, PAGE, VPSTTL, BDYTTL  PAGE 

WRITE  (NT, 95)  (BLANK, J , J*J1 , J2)  HEDING 

DO  92  JsJl , J2  HEDING 

Ml  *  MSDM(J)  HEDING 

N1  =  MSDN(J)  HEDING 

POSSIBLE  OVERFLOW  INTO  NOPL  ARRAY  IS  INTENTIONAL.  HEDING 

HEAD(2«J-1)  =  SEG(Ml)  HEDING 

92  HEAD (2* J  )  =  SEG(Nl)  HEDING 

WRITE  (NT, 96) (BLANK ,MSDM(J) ,HEAD(2»J-1) ,MSDN(J) ,HEAD(2«J) , J»J1 ,J2) HEDING 
WRITE  (NT, 97)  (BLANK ,J=J1 ,J2)  HEDING 

WRITE  (NT, 98)  (BLANK, UNITL, UNITM, J=J1 ,J2)  HEDING 

WRITE  (NT, 38)  HEDING 

IF  (.NOT. LNEW)  GO  TO  94  HEDING 

JJ  =  2» (J2-J1+1)  HEDING 

DO  93  I « 1 , NLINES  HEDING 


03  WHITE  (NT, 90)  USEC(I) . (ZTTH(J,I ,IT) ,J3l ,JJ)  HEDING 

94  continue  hedimq 

95  FOBMAT ( ’ 0 ' , 26X , * SPRING  DAMPED  FOBCES 1 /  HEDIMQ 

*  9X,4(A3,3X, 'SPBIMG  DAMPEB  MO. \I3,4X))  HEDIMQ 

96  F0BMAT(9X, 4 (A3 , ’SEQ’ , 13 , ’ ( ’ , A4 , ’ )  -  SEQ’ ,13, ’ (* ,A4, ') *))  HEDIMQ 

97  F0BMAT(4X, ’TIME’ , 1X,4(A3,5X, ’LENGTH' ,7X, ’FOBCE’ ,4X))  HEDIMQ 

98  FOBMAT (3X, * (MSEC) * ,4 (A3, 5X, * ( ’ , A4, ’ ) ’ ,6X, ’ ( ’ ,A4 , ’ ) ’ ,4X) )  HEDIMQ 

99  FOBMAT  (F9. 3.4 (FI4. 3.F12. 2 ,4X) )  HEDIMQ 

HEDIMQ 

SEGMENT  FOBCES  HEADINGS  HEDIMQ 

HEDINQ 

63  MSSF  =  0  HEDINQ 

IF  (NPBT(18) . EQ . 5 . OB. NPBT ( 18) .EQ. 13)  GOTO  161  VABTTH 

IF  (MPBT(18) .EQ. 10.0B.NPBT(18) .EQ. 11)  00  TO  161  VABTTH 

IF  (NPBT (18) .QE. 15)  GO  TO  161  VABTTH 

DO  65  J=  1 , MSEQ  HEDINQ 

IF  (MMSEQ(J) .EQ.O)  00  TO  65  HEDIMQ 

LSEQ  *  MMSEQ(J)  HEDIMQ 

DO  64  1 3 1 , LSEQ  HEDIMQ 

MSSF  3  MSSF+1  HEDIMQ 

NOPL(MSSF)  3  J  HEDIMQ 

64  MOPL(MSSF)  3  MSEQ (2, I, J)  HEDIMQ 

65  CONTINUE  HEDINQ 

IF  (MSSF. EQ.O)  GO  TO  70  HEDING 

DO  67  J31.MSSF  HEDINQ 

MT  3  W  ♦  1  HEDINQ 

NT  3  XT  HEDINQ 

IF  (LMEW)  NT  3  6  HEDINQ 

P  &  E  CABBIAQE  CONTROL  PECONV 

CALL  CABC0N(NT,1)  PECONV 

IT  3  MT  -  20  HEDINQ 

PAGE  3  FLOAT (MT)  ♦  XPAQE  HEDINQ 

IF  (NT.EQ.6)  WBITE(NT, 121)  DATE , BLANK , NPQ  PAGE 

IF  (NT. ME. 6)  WBITE(NT, 121)  DATE  PAGE 

IF  (NT.EQ.6)  NPG=MPG+1  PAGE 

WRITE  (NT .21)  COMENT , PAGE , VPSTTL , BDYTTL  PAGE 

N1  3  NOPL(J)  HEDINQ 

Ml  3  MOPL (J)  HEDINQ 

WRITE  (MT.68)  Ml ,SEQ(M1) ,M1 .SEQ(Ml) .UMITL.Ml .Ml  HEDINQ 

«  , UNITL , UNITM, UNITM, UNITM  HEDINQ 

IF  ( . NOT . LNEW)  GO  TO  67  HEDING 

DO  66  I31.NLINES  HEDINQ 

66  WRITE  (NT,  69)  USEC(I) , (ZTTH(JJ, I , IT) , JJ31 , 10)  HEDINQ 

67  CONTINUE  HEDIMQ 

68  FORMAT  CO  ’  ,26X,  'CONTACT  FORCES  -  SEGMENT  NO.’ ,13,’  (\A4,  HEDINQ 

*  ’)  VS.  SEGMENT  NO. ’ ,13, ’  ( * ,A4, * ) *//  HEDINQ 

»  13X/DEFL-  NORMAL  FRICTION  RESULTANT'  ,  HEDINQ 

*  1 4X,’ CONTACT  LOCATION  (' ,A4,’) V  HEDINQ 

»  4X, ’TIME  ECTION' ,3(3X, 'FOBCE' , IX) ,  HEDINQ 

»  2 ( ’  SEQ. ’,13, ’  LOCAL  BEFEBENCE  ')/  HEDINQ 


c 

c 

c 


»  3X, * (MSEC) ’ ,3X, ' ( ' , A4 , ' ) ’ ,  3 (3X, ’ ( ' ,A4 , ’ ) * ) , 

*  2(5X, ’X’ ,7X, ’Y’ ,7X, ’Z’ , 4X)/1X) 

69  FORMAT ( 2F9 . 3 , 3F9 . 2 , 3F8 . 3 , 2X , 3F8 . 3 ) 

161  CONTI HUE 

AIRBAG  FORCES  HEADINGS 

70  IF  (NBAG.EQ.O)  GO  TO  82 

IF  (NPRT(lfi) .EC.6.0R.NPRT » 18) .EQ.9)  GO  TO  82 
IF  (NPRT ( 18) .GE. 12)  GO  TO  82 
DO  77  J=1,NBAG 
IF  (MNBAG(J) .EQ.O)  GO  TO  77 

mt  =  «rr  +  l 

NT  =  MT 

IF  (LNEW)  NT  =  6 
P  &  E  CARRIAGE  CONTROL 
CALL  CARCON(NT.l) 

IT  =  MT  -  20 

PAGE  =  FLOAT  (W)  ♦  XPAGE 

IF  (NT.EQ.6)  WRITE(NT, 121)  DATE , BLANK , NPG 

IF  (NT.NE.6)  WRITE (NT, 121)  DATE 

IF  (NT.EQ.6)  NPG=NPG+ 1 

WRITE  (NT, 21)  COMENT , PAGE , VPSTTL , BD YTTL 

WRITE  (NT, 78)  J ,  (BAGTTLU  ,  J)  ,  1  =  1 ,5) 

IF  (.NOT. LNEW)  GO  TO  72 
DO  71  1=1 .NLINES 

71  WRITE  (NT,  79)  USEC(I) , (ZTTH(JJ , I , IT) , JJ=1 , 12) 

72  KBAG  =  0 

KP  =  NPANEL(J) >1 
DO  73  K= 1 , KP 
KBAG  =  KBAG+1 

73  HEAD (KBAG)  =  PHED(K) 

KP  =  MNBAG(J) 

DO  74  K= 1 ,KP 
KBAG  =  KBAG+1 
M  =  MBAG ( 2 , K , J ) 

74  HEAD (KBAG)  =  SEG(M) 

DO  76  J 1 = 1 , KBAG , 4 

J2  =  MINO ( Jl+3 , KBAG) 

MT  =  MT  +  1 
NT  =  MT 

IF  (LNEW)  NT  =  6 
P  &  E  CARRIAGE  CONTROL 
CALL  CARCON(NT.l) 

IT  =  MT  -  20 

PAGE  =  FLOAT (MP)  ♦  XPAGE 

IF  (NT.EQ.6)  WRITE(NT, 121)  DATE , BLANK , NPG 

IF  (NT.NE.6)  WRITE (NT, 121)  DATE 

IF  (NT.EQ.6)  NPG=NPG+ 1 

WRITE  (NT, 21)  COMENT , PAGE , VPSTTL , BDYTTL 


HEDING 

HEDIHG 

HEDING 

VARTTH 

HEDING 

HEDING 

HEDING 

HEDING 

VARTTH 

VARTTH 

HEDING 

HEDING 

HEDING 

HEDING 

HEDING 

PECONV 

PECONV 

HEDING 

HEDING 

PAGE 

PAGE 

PAGE 

PAGE 

HEDING 

HEDING 

HEDING 

HEDING 

HEDING 

HEDING 

HEDING 

HEDING 

HEDING 

HEDING 

HEDING 

HEDING 

HEDING 

HEDING 

HEDING 

HEDING 

HEDING 

HEDING 

HEDING 

PECONV 

PECONV 

HEDING 

HEDING 

PAGE 

PAGE 

PAGE 

PAGE 
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WRITE  (NT,80)UNITM,J,  (BAGTTLd  ,J)  ,1  =  1,5)  ,  ( BLANK,  J,  HE  AD  (K)  ,K=J1 ,  J2)  HEDIHG 


WRITE  (NT, 51)  (BLANK, K=J1,J2)  HEDINQ 

WRITE  (NT, 38)  HEDINQ 

IF  ( . NOT . LNEW)  00  TO  76  HEDINQ 

JJ  =  3» (J2-J1+1)  HEDINQ 

DO  75  1=1 , NLINES  HEDINQ 

75  WRITE  (NT,  81)  USEC(I) . (ZTTH(K,I ,IT) ,K=1 ,JJ)  HEDINQ 

76  CONTINUE  HEDING 

77  CONTINUE  HEDINQ 

78  FORMAT ( 'O’ ,26X,’ PARAMETERS  FOR  AIRBAG  NO. ’ ,I2,4X,5A4//  HEDINQ 

*  16X, 'SUPPLY  CYLINDER  STATIC*/  HEDINQ 

«  4X, ’TIME* ,8X, ’PRES. * ,4X, 'TEMP. ' ,4X, ’PRES. ' , 12X, ’AIRBAG’ ,  HEDING 

»  3X, ’CENTER ’,14X, ’AIRBAG  SEMIAXES' , 12X, ’ORIENTATION  (DEQ. ) ’/  HEDINQ 

«  3X, ’ (MSEC) ’ ,7X, ’ (PSIQ)  (DEQ.R)  (PSIG) ’ ,8X, 'X' ,8X, *Y’ ,8X, ’Z’ ,  HEDING 

«  11X, ’A', 8X,’B’,8X.’C’,10X, 'YAW*. 4X, ’PITCH’, 5X, ’ROLL’/  )  HEDING 

79  FORMAT  (F9.3,3X,3F9.2,2(3X,3F9.3) .3X.3F9.2)  HEDINQ 

80  FORMAT! ’0’ ,20X, ’CONTACT  FORCES  (’.A4,’)  ON  AIRBAQ  NO.  ’  ,  12 , 4X ,  5A4//HEDING 

»  /4X,’TIME’,4(A1,11X, ’AIRBAG’, 12,’  VS.  ’,A4,1X))  HEDING 

81  FORMAT  (F9.3,4(3X,3F9.2) )  HEDING 

82  RETURN  HEDING 

END  HEDING 
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SUBROUTINE  HERRON ( HD3 , NT 1 .THETO .THETOP) 


C 

C 

C 

C 

C 

C 

C 


C 

C 

C 

C 

C 

c 

c 

c 

c 

c 


COMPUTES 


FROM 


THETO  - 
THETOP - 

HD3 

NT1 


ANGLE  OF  JOINT  STOP 
DERIVATIVE  OF  THETO 


REV  IV 


WITH  RESPECT  TO  PHI 


HERRON 

07/23/86TW0PI 
HERRON 
HERRON 
HERRON 
HERRON 
HERRON 
HERRON 

IMPLICIT  REAL*8 (A-H.O-Z)  HERRON 

COMMON/ TABLES /MXNT I , MXNTB , MXTB 1 , MXTB2 , NTI (50) , NTAB ( 1250) , TAB (4500) DIMENB 


COMPONENTS  OF  VECTOR  DEFINING  PHI 
INDEX  TO  TAB  ARRAY  DEFINING  FUNCTION 


COMMON/CNSNTS/  PI .RADIAN, G, THIRD, EPS (24) , 

*  UNITL , UNITM, UNITT , GRAVTY (3) .TWOPI 

DIMENSION  HD3 (3) 

IF  (TAB(NT1+1) .LE.O.O)  GO  TO  30 
IF  (TAB(NTl+2) .LE.O.O)  GO  TO  30 

THETO  =  PI (CP)  +  SP*P2 (CP) 

THETOP  =  -SP*P1’(CP)  +  CP*P2 (CP)  -  SP«»2*P2 ’ (CP) 

WHERE  PI (X) ,P2 (X)  ARE  THE  TWO  5TH  ORDER  POLYNOMIALS  DEFINED 
IN  TAB(NTl+5)  AND  TAB(NT1+11) 

Pr(X),P2’(X)  ARE  THEIR  DERIVATIVES  WITH  RESPECT  TO  PHI 


HERRON 

TWOPI 

HERRON 

HERRON 

HERRON 

HERRON 

HERRON 

HERRON 

HERRON 

HERRON 

HERRON 

HERRON 

HERRON 


AND  SP.CP  ARE 

SIN (PHI)  AND  COS (PHI) 

HERRON 

HERRON 

STH2  = 

I . 0-HD3 (3) **2 

HERRON 

STH  = 

DSQRT(STH2) 

HERRON 

CP 

HD3( 1) /STH 

HERRON 

SP 

HD3 (2) /STH 

HERRON 

PI 

TAB(NTH5  )♦ 

CP*(TAB(NTl+6  ) 

HERRON 

* 

♦ 

CP« (TAB (NT1+7  ) 

HERRON 

» 

♦ 

CP« (TAB (NT  1*8  ) 

HERRON 

« 

+ 

CP«(TAB(NTl+9  ) 

HERRON 

» 

CP* (TAB (NT  1  +  10)  ))))) 

HERRON 

P2 

TAB(NT1+11) ♦ 

CP* (TAB(NT1+12) 

HERRON 

ft 

CP* (TAB(NT1+13) 

HERRON 

ft 

+ 

CP* (TAB(NT1+14) 

HERRON 

ft 

♦ 

CP* (TAB (NT  1  +  15) 

HERRON 

» 

+ 

CP* (TAB(NT1+18)  ))))) 

HERRON 

PIP  = 

TAB (NT  1+6  )♦ 

CP* (2 .0*TAB (NT 1+7  ) 

HERRON 

« 

♦ 

CP* (3 . 0*TAB (NT 1+8  ) 

HERRON 

ft 

+ 

CP* (4.0*TAB(NTl+9  ) 

HERRON 

» 

+ 

CP* (5 . 0»TAB (NT1+ 10)  )))) 

HERRON 

P2P  = 

TAB (NTI ♦12) + 

CP* (2 .0*TAB (NTI +13) 

HERRON 

ft 

♦ 

CP»(3.0*TAB(NT1+14) 

HERRON 

ft 

+ 

CP* (4.0*TAB(NT1+15) 

HERRON 

ft 

♦ 

CP* (5 . 0*TAB ( NT 1+16)  )))) 

HERRON 

THETO 

=  PI  ♦  SP#P2 

HERRON 

THETOP 

=  CP«P2  -  SPMP1P  +  SP»P2P) 

HERRON 

GO  TO 

99 

HERRON 

c 

HERRON 

c 

EVALUATE  THETO  AND  THETOP  FROM  REGULAR  FUNCTION  DEFINITION 

WHERE  HERRON 

c 

THETO  (ORDINATE)  IS  A  FUNCTION  OF  PHI  (ABSCISSA)  (0  <  PHI 

<  2»PI) HERRON 

c 

HERRON 

30 

PHI  =  DATAN2 (HD3(2) ,HD3(1) ) 

HERRON 

IF  (PHI. LT. 0.0)  PHI  =  PHI  +  TWOPI 

TWOPI 

THETO  =  E VALFD ( PHI , NT  1 , 1 ) 

HERRON 

THETOP  =  EVALFD(PHI ,NT1 ,0) 

HERRON 

99 

RETURN 

HERRON 

END 

HERRON 
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SUBROUTINE  HICCSI(NPTS) 


REV  IV 


HICCSI 

I0/08/87PLTIMC 

HICCSI 


COMPUTES  HIC,  HSI  AND  CSI  FOR  CVS  PROGRAM. 


ASSUMES  Z  ARRAY  CONTAINS 

Z(I,1  ) , 1= 1 ,NPTS  :  TIME  POINTS  (SECONDS) 

Z(I.JH) ,I=1,NPTS  :  HEAD  RESULTANT  ACCELERATIONS  (G’S) 
Z(I.JC) ,I=1,NPTS  :  CHEST  RESULTANT  ACCELERATIONS  (G’S) 


IF  JDTPTS ( 1 ) =0 ,  HEAD  RESULTANT  IS  NOT  AVAILABLE  (JH=MULLt 
IF  JDTPTS (2) =0.  CHEST  RESULTANT  IS  NOT  AVAILABLE  (JH=2,JC= 
OTHERWISE.  JH=2  AND  JC=3. 


JC=2) 

NULL) 


COMMON/CDINT/  JDTPTS ( 18) ,Z ( 1000 , 3) 

COMMON/CONTRL/  TIME , NSEG , NJNT , NPL , NBLT , NBAG . NVEH , NGRND . 

*  NS , NQ , NSD , NFLX , NHRNSS , NWINDF , NJNTF . NPRT (36) 

REAL* 8  TIME 
DIMENSION  AREA(IOOO) 

IF  (NPTS.LT.25)  GO  TO  25 
WRITE  (6,14)  NPG 


NPG=NPG+1 
FORMAT  (1H1, 


HIC,  HSI  AND  CSI  RESULTS’ ,96X, ’PAGE’ .15) 


-  2 
=  3 

(JDTPTS (1) . EQ.O) 
=  0.0 
=  0.0 
=  0.0 
=  Z(1,JC) 

=  Z(1,JH) 

(JDTPTS (2) .EQ.O) 


GO  TO  16 


COMPUTE  CSI  -  CHEST  SEVERITY  INDEX 


HI  =  SQRT (Z ( 1 , JC) )  *  Z( 1 , JC) **2 
DO  15  1=2  ,NPTS 

H2  =  SQRT(Zd.JC))  »  Z  ( I ,  JC)  **2 
DT  =  Z(I,1)  -  Z(I-l.l) 

CSI  =  CSI  +  0. 5*DT* (H1+H2) 

IF  (CMX.GT.Zd  ,  JC) )  GO  TO  15 
CMX  =  Z(I,JC) 

COT  =  Z  ( 1 , 1 ) 

HI  =  H2 


CSI  =  0.001»CSI 


(JDTPTS (1) .EQ.O)  GO  TO  23 


COMPUTE  HSI  -  HEAD  SEVERITY  INDEX  -  AND  AREA  TABLE 


HICCSI 

HICCSI 

HICCSI 

HICCSI 

HICCSI 

HICCSI 

HICCSI 

HICCSI 

HICCSI 

HICCSI 

HICCSI 

HICCSI 

PLTINC 

PAGE 

PAGE 

PAGE 

PLTINC 

HICCSI 

PAGE 

PAGE 

PAGE 

HICCSI 

HICCSI 

HICCSI 

HICCSI 

HICCSI 

HICCSI 

HICCSI 

HICCSI 

HICCSI 

HICCSI 

HICCSI 

HICCSI 

HICCSI 

HICCSI 

HICCSI 

HICCSI 

HICCSI 

HICCSI 

HICCSI 

HICCSI 

HICCSI 

HICCSI 

HICCSI 

HICCSI 

HICCSI 

HICCSI 


IV 


P 


AREA ( 1 )  =  0.0 


HICCSI 


HI  =  SQRT(Z(1,JH))  »  Z(1,JH)««2  HICCSI 

DO  17  1=2, HPTS  HICCSI 

H2  =  SQRT(Z(I,JH))  »  Z(I,JH)»»2  HICCSI 

DT  =  0.5*  (Z  <  1 , 1)  -  Zd-1,1))  HICCSI 

AREAd)  =  AREA  ( I  - 1 )  +  DT» (Z ( I - 1 , JH) +Z ( I ,  JH) )  HICCSI 

HSI  =  HSI  +  DT» (H1+H2)  HICCSI 

IF  (HMX.GT.Z(I.JH))  GO  TO  17  HICCSI 

HMX  =  Z(I,JH)  HICCSI 

HMT  =  Z Cl .  1 )  HICCSI 

17  HI  =  H2  HICCSI 

HSI  =  0.001*HSI  HICCSI 

C  HICCSI 

C  COMPUTE  HIC  -  HEAD  INJURY  CRITERION  -  AND  TIME  DURATION  HT1.HT2  HICCSI 

C  HICCSI 

DO  19  K=2 ,NPTS  HICCSI 

DO  18  L=K ,NPTS  HICCSI 

DT  =  Z(L, 1)  -  Z(K-1 , 1)  HICCSI 

DH  =  AREA(L)  -  AREA(K-l)  HICCSI 

HT  =  DH/DT  HICCSI 

HM  =  DT*SQRT(HT) *HT»«2  HICCSI 

IF  (HM.LE.HIC)  GO  TO  18  HICCSI 

HIC  =  HM  HICCSI 

HT1  =  ZCK-1 . 1)  HICCSI 

HT2  =  Z(L.l)  HICCSI 

HA2  =  Z(L.JH)  HICCSI 

HA1  =  Z (K- 1 , JH)  HICCSI 

AVE  =  HT  HICCSI 

18  CONTINUE  HICCSI 

19  CONTINUE  HICCSI 

HIC  =  O.OOUHIC  HICCSI 

WRITE  (6,21)  HIC,HT1,HT2,HA1, HA2 , AVE  HICCSI 

21  FORMAT  ( 1H0 ,  ’  HEAD  INJURY  CRITERION’//  HICCSI 

»  ’  HIC  =  ’,  F8.2,  HICCSI 

*  9X,  ’TIME  DURATION  =  ’,  F9.3,  ’  TO  ’ ,  F9.3,  ’  MSEC’/  HICCSI 

»  20X,  ’WITH  HEAD  RESULTANTS  =  ’,  F9.3,  ’  AND  ’,  F9.3,  ’  G” S’ //HICCSI 

«14X,  ’AVERAGE  HEAD  RESULTANT  FOR  TIME  DURATION  =  ’,  F9.3,  ’  G”S’)  HICCSI 
WRITE  (6,22)  HSI , HMX, HUT  HICCSI 


22  FORMAT  (1H0,  '  HEAD  SEVERITY  INDEX’// 

*  ’  HSI  =  ’ ,  F8.2// 

«  ’  MAX  HEAD  RESULTANT  =  ’,  F9.3,  ’  G”S  AT  ’,  F9.3, 

23  IF  (JDTPTS(2) .EQ.O)  GO  TO  25 
WRITE  (6,24)  CSI.CMX.CMT 

24  FORMAT  (1H0,  ’  CHEST  SEVERITY  INDEX’// 

«  ’  CSI  =  ’,  F8.2// 

»  '  MAX  CHEST  RESULTANT  =  ’,  F9.3,  ’  G”S  AT  ’,  F9.3, 

25  CONTINUE 

IF(NPTS.LT.25)  WRITE(6,101)  NPTS 
101  FORMAT ( IX, // , 2X, ’ HIC ,  HSI  AND  CSI  NOT  COMPUTED  BECAUSE  THE  NUMBER  TGM0D1 
•OF  POINTS  TO  BE  USED  IN  THE  COMPUTATION  =’, 12 ,’,’,/ ,2X  TGM0D1 


HICCSI 
HICCSI 
MSEC’) HICCSI 
HICCSI 
HICCSI 
HICCSI 
HICCSI 
MSEC’) HICCSI 
TGM0D1 
TGM0D1 


SUBROUTINE  HINPUT  HINPUT 

REV  IV  07/23/86TWOPI 

CONTROLS  THE  INPUT  OF  CARDS  F.8.A  -  F.8.D  CONTAINING  THE  SETUP  ANDHINPUT 
CONTROL  OF  THE  HARNESS  BELT  SYSTEM.  HINPUT 

HINPUT 

HINPUT 

IMPLICIT  REAL*8 (A-H.O-Z)  HINPUT 

COMMON/CONTRL/  T I ME , NSEG , NJNT , NPL , NBLT , NBAG , NVEH , NGRND ,  HINPUT 

*  NS , NQ , NSD , NFLX , NHRNSS , NWINDF , NJNTF , NPRT (36 ) , NPG  PAGE 

COMMON/CNSNTS/  PI , RADI AN ,G, THIRD, EPS (24) ,  HINPUT 

*  UNITL , UNITM, UNITT , GRAVTY(3) .TWOPI  TWOPI 

COMMON/ HRNESS/  BAR(15, 100) ,BB(100) .BBDOT(IOO) .PLOSS (2 , 100) ,  HINPUT 

*  XL0NG(20) , HTIME (2) , IBAR(5 , 100) ,NL (2 , 100) ,  HINPUT 

*  NPTSPB(20) ,NPTPLY(20) ,NTHRNS(20) ,NBLTPH(5)  HINPUT 

COMMON/TABLES/MXNTI .MXNTB ,MXTB1 ,MXTB2 , NTI (50) ,NTAB(1250) .TAB (4500) DIMENB 
COMMON/CNTSRF/  PL (24 . 30) ,BELT(20 , 8) ,TPTS (6 ,8) ,BD (24 , 40)  EDGE 

COMMON/TITLES/  DATE(3) ,C0MENT(40) ,VPSTTL(20) ,BDYTTL(5) ,  HINPUT 

*  BLTTTL(5,8) ,PLTTL(5,30) ,BAGTTL(5,6) ,SEG(30) ,  HINPUT 

*  JOINTOO)  ,CGS(30)  ,JS(30)  HINPUT 

REAL  DATE , COMENT , VPSTTL . BDYTTL . BLTTTL , PLTTL , BAGTTL , SEG . JO I NT  HINPUT 

LOGICAL* 1  CGS.JS  HINPUT 

THIS  COMMON/TEMTVS/  IS  SHARED  BY  CINPUT,  FINPUT,  HINPUT  AND  FDINITHINPUT 
COMMON/TEMPVS/  JTITLE (5 . 5 1 ) ,NF (5) , MS (3) . KTITLE (3 1 )  HINPUT 

REAL  JTITLE. KTITLE  HINPUT 

IF  (NHRNSS. EQ.O)  GO  TO  99  HINPUT 

HINPUT 

INPUT  CARD  F.8.A  HINPUT 

(NOTE:  NHRNSS  NOW  SUPPLIED  ON  INPUT  CARD  D.l)  HINPUT 

NBLTPH  -  NO.  OF  BELTS  PER  HARNESS  HINPUT 

HINPUT 

READ  (5,11)  (NBLTPH( I) ,1=1 .NHRNSS)  HINPUT 

11  FORMAT (1814)  HINPUT 

WRITE  (6.12)  NPG . NHRNSS , ( NBLTPH ( I ) ,1=1, NHRNSS )  PAGE 

NPG=NPG+ 1  PAGE 

12  FORMAT ( ’ 1  HARNESS-BELT  SYSTEM  INPUT’ ,96X, ’PAGE ’,15/1 20X,  PAGE 

*  'CARDS  F. 8 ’ / ’  NO.  OF  HARNESSES  =’,I4//  PAGE 

*  ’  NO.  OF  BELTS  PER  HARNESS  =’,516)  HINPUT 

J1  =  1  HINPUT 

K 1  =  1  HINPUT 

DO  90  1=1, NHRNSS  HINPUT 

IF  (NBLTPH(I) .LE.O)  GO  TO  90  HINPUT 

J2  =  J1  +  NBLTPH ( I )  -1  HINPUT 

HINPUT 

INPUT  CARD  F.8.B  -  NPTSPB  -  NO.  OF  POINTS  PER  BELT.  HINPUT 

HINPUT 

READ  (5,11)  (NPTSPB(J) ,J=J1 ,J2)  HINPUT 

WRITE  (6,13)  I , (NPTSPB (J) , J=J1 ,J2)  HINPUT 

13  FORMAT ( ’ 0  FOR  HARNESS  NO. ’,13,’  NO.  OF  POINTS  PER  BELT  =’,2014)  HINPUT 

DO  80  J=J1,J2  HINPUT 

IF  (NPTSPB(J) .EQ.O)  GO  TO  80  HINPUT 


H INPUT 

INPUT  CARD  F.8.C  -  5  FUNCTION  NOS  AND  LENGTH  OF  EACH  BELT.  HINPUT 

HINPUT 

READ  (5,14)  NF.XLONG(J)  HINPUT 

14  FORMAT (514 ,F12 . 6)  HINPUT 

WRITE  (6,15)  I , J,NF,XL0N6(J) .UNITL  HINPUT 

15  FORMAT ( ’ 0  HARNESS  NO. '.13,'  BELT  NO. ’,13.’  FUNCTION  NOS.’, 516,  HINPUT 

«  '  REFERENCE  SLACK  =  ’ ,F9. 3 , IX.A4/)  HINPUT 

IF  (XLONG(J) . EQ.O.O)  XLONG(J)  =EPS(24)  HINPUT 

WRITE  (6,16)  HINPUT 

16  FORMAT  CO  K  KS  KE  NT  NPD  NDR  FUNCTION  NOS .’ ,  HINPUT 

«  66X, 'CARDS  F.8.D'/)  CHGIII 

HINPUT 

SET  UP  POINTERS  IN  NTAB  AND  INITIAL  VALUES  OF  TAB  FOR  BELT  J  HINPUT 

AS  WAS  DONE  FOR  OTHER  CONTACTS  IN  SUBROUTINE  FINPUT.  HINPUT 

HINPUT 

NTHRNS(J)  =  MXNTB+ 1  HINPUT 

CALL  FDINIT  HINPUT 

K2  =  K1  ♦  NPTSPB(J)  -  1  HINPUT 

DO  70  K=K1 ,K2  HINPUT 

HINPUT 

INPUT  CARD  F.8.D  HINPUT 

HINPUT 

READ  15.21)  KS , KE , NPD , NDR , NF ,  (BAR(L.K) ,L=1 ,3)  HINPUT 

21  FORMAT  (9I4.3F12.0)  HINPUT 

READ  (5,22)  (BAR(L.K) ,L=7 , 12)  HINPUT 

22  FORMAT  (6F12.0)  HINPUT 

ICHEC  =  0  CHGIII 

IF  (K.EQ.K1.0R.K.EQ.K2)  ICHEC  =  1  CHGIII 

IF  (ICHEC. EQ. 1. AND. NPD. EQ.O)  STOP  60  CHGIII 

IF  ( ICHEC. EQ. 1. AND. NDR. EQ.O)  STOP  61  CHGIII 

IF  (NDR. EQ.O. AND. NPD. NE.O)  STOP  62  CHGIII 

IBAR(l.K)  =  KS  HINPUT 

IBAR(2,K)  =  KE  HINPUT 

I BAR (4 ,K)  =  NPD  HINPUT 

IBAR(5,K)  =  NDR  HINPUT 

IBAR(3,K)  =  MXNTB+1  HINPUT 

CALL  FDINIT  HINPUT 

SQRER  =  1.0  HINPUT 

IF  (KE.NE.O)  SQRER  =  DSQRT (XDY(BAR ( 1 ,K) , BD (7 ,KE) , BAR( 1 ,K) ) )  HINPUT 

DO  26  L= 1 , 3  HINPUT 

IF  (KE.NE.O)  BAR(L+6.K)  =  BD(t.+3,KE)  HINPUT 

26  BAR(L+3 ,K)  =  BAR(L ,K) /SQRER  HINPUT 

WRITE  (6,31)  K, (IBAR(L.K) , L=1  ) ,NF  HINPUT 

31  FORMAT  (1116)  HINPUT 

70  CONTINUE  HINPUT 

WRITE  (6,71)  UNITL, UNITL, UNITL, UNITL  HINPUT 

71  FORMAT  CO’ ,12X,’ BASE  REFERENCE  C,  A4 ,  ’ )  ’  ,  HINPUT 

*  7X, ’ADJUSTED  REFERENCE  ( ’ ,  A4 , ’ ) ’ ,  HINPUT 

*  1 IX, 'OFFSET  (’,  A4 , ’ ) ’ ,  HINPUT 


iVll 

Aul 

utsl 

if 

r 


) 

1 

1 IX, ’PREFERRED  DIRECTION  ( ’ , A4 , ’ ) ’ / 

HINPUT 

i 

t  5X, 

’K’,  4(8X, ’X’ ,8X, ’Y’ ,8X, ’Z’ ,3X)  /) 

HINPUT 

WRITE  (6,72)  (K, (BAR(L.K) ,L=1 , 12) ,K=K1 ,K2) 

HINPUT 

72 

FORMAT  ( 16 , 3X.3F9. 3 , 3X, 3F9 . 3 , 3X, 3F9 . 3 , 3X.3F9 . 3) 

HINPUT 

K1  =  K2+ 1 

HINPUT 

80 

CONTINUE 

HINPUT 

J1  =  J2  + 1 

HINPUT 

90 

CONTINUE 

HINPUT 

DO  92  K= 1 

,100 

HINPUT 

BBDOT(K)  = 

0.0 

HINPUT 

DO  91  J=1 

,2 

HINPUT 

91 

FLOSS(J,X) 

=  0.0 

HINPUT 

DO  92  J=1 

,3 

HINPUT 

92 

BAR ( J+ 12 , K) 

=  0.0 

HINPUT 

99 

RETURN 

HINPUT 

END 

HINPUT 

SUBROUTINE  HPTURB 


HPTURB 

REV  IV  07/23/86TW0PI 
IMPLICIT  REAL *8  (A-H.O-Z)  HPTURB 

COMMON/CONTRL/  T I  ME , NSEG , NJNT , NPL , NBLT , NBAG , NVEH , NGRND ,  HPTURB 

*  NS , NQ , NSD , NFLX , NHRNS S , NWI NDF , NJNTF , NPRT ( 36 ) , NPG  PAGE 

COMMON/CNSNTS/  PI .RADIAN, G, THIRD, EPS (24) ,  HPTURB 

»  UNITL , UNITM, UNITT .GRAVTY (3) .TWOPI  TWOPI 

COMMON/CNTSRF/  PL (24 , 30) .BELT (20 , 8) ,TPTS (6 ,8) ,BD(24 ,40)  EDGE 

COMMON/SGMNTS/  D(3,3,30) ,WMEG(3,30) ,WMEGD(3,30) ,U1 (3,30) ,U2(3,30) .HPTURB 

*  SEGLP(3,30) ,SEGLV(3,30) ,SEGLA(3,30) ,NSYM(30)  HPTURB 

COMMON/RSAVE/  XSG(3 , 20 , 3)  .DPMI  (3 ,3 , 30)  . LPkfl  (30)  ,  ATBIII 

*  NSG(9) ,MSG(20,9) , MCG,14CGIN(24 ,5) ,KREF(20,9)  TTHKREF 

COMMON/ HRNESS/  BAR ( 15 . 100) ,BB ( 100) .BBDOT ( 100) .PLOSS (2 , 100) ,  HPTURB 

*  XLONG (20) , HTIME (2) , I BAR (5 ,100) ,NL(2 , 100) ,  HPTURB 

*  NPTSPB(20) ,NPTPLY(20) ,NTHRNS(20) , NBLTPH(5)  HPTURB 

THIS  COMMON/TEMPVS/  IS  SHARED  BY  HPTURB,  HBPLAY,  HBELT  AND  HSETC.  HPTURB 
COMMON /TEMP VS/  B (3 , 3 , 3) ,S (3 , 3) ,T (3) , R (3) , V(3) ,T1 (3) ,T2 (3) ,  HPTURB 

»  E(3,3,50) ,ED0T(3,50) ,FCE(3,50) ,FR(3,50) ,ZR(3,50) ,  HPTURB 

*  TR (3 , 50) , U(3 , 50) .PTLOSS (2 , 50) ,BL(50) ,FB(50) ,FP(50) .HPTURB 

»  OLDBB(IOO) ,RHS(3,54) ,C(3,3,200) ,IJK(54,54)  HPTURB 

DIMENSION  BL0SS(2,20) ,HL0SS(2,5)  HPTURB 

EQUIVALENCE  (BLOSS (1,1) ,C(i.l.l))  ,  (HLOSS ( 1 , 1 ) ,C ( 1 , 1 , 10) )  HPTURB 

LOGICAL  LAST  HPTURB 

DATA  MAXI TR/ 10/  HPTURB 

CALL  ELTIME  (1,39)  HPTURB 

CALL  HBPLAY  HPTURB 

DHT  =  0.0  HPTURB 

IF  (TIME. NE. 0.0)  DHT  =  TIME  -  HTIME(l)  HPTURB 

HTIME (1)  =  TIME  HPTURB 

DO  11  J= 1,100  HPTURB 

PTLOSS (J.l)  =0.0  HPTURB 

OLDBB(J)  =  BB ( J)  HPTURB 


DO  11  1=1,3  HPTURB 

11  BAP(I.J)  =  BAR ( I +3 , J)  HPTURB 

TSEC  =  1000 . 0*TIME  HPTURB 

IF  (NPRT (28) . NE . 0)  WRITE  (6,12)  TSEC ,NPG,UNITL,UNITM,UNITL,  PAGE 

»  UNITL , UNITM, UNITL , UNITM  HPTURB 

IF  (NPRT (28) .NE.O)  NPG=NPG+1  PAGE 

12  FORMAT  Cl  HARNESS  BELT  RESULTS  FOR  TIME  =',F9.3,’  MSEC. ’ ,73X,  PAGE 

*  ’PAGE ’,15///  PAGE 

»  36X, ’BELT  STRAIN’ ,6X,  ’  (LOCAL  OR  ELLIPSOID)  M8X,  CHGIII 

«  ’ (INERTIAL) ’, 14X, ’PENETRATION’/  CHGIII 

»  ’  POINT  POINT  SEGMENT  LENGTH  ENERGY  LOSS ’, 5X,  HPTURB 

*  ’REFERENCE  POINT  (’ ,A4, ’)’ ,13X, ’BELT  FORCES  (’.A4,’)’,  AFREVS 

»  9X, ’ ENERGY  LOSS ’ /  HPTURB 

*  ’  NO.  INDEX  NO.  ( ’ , A4 , ’ )  ( ’ ,2A4, ’ ) ’ ,7X,  HPTURB 

»  ’ X' , 8X, ’ Y’ ,8X, ’ Z’ , 13X, ’X’ , 10X, ’ Y’ , 10X, ’Z’ ,8X, ’ ( ’ ,2A4 ,’)’/)  HPTURB 

J1  =  1  HPTURB 

KO  =  1  HPTURB 

KNLO  =  0  HPTURB 


c 

c 

c 


c 

c 

c 


DO  61  NH= 1 , NHRNSS 

IF  (NBLTPH(NH)  . LE.O)  GO  TO  81 

ITER  =  1 

KNL1  =  KNLO 

KNLN  =  0 

START  OF  DO  59  ITER=1 .MAXITR  LOOP 

13  NJ2  =  54 

DO  14  1=1 ,NJ2 

DO  14  J= 1 ,NJ2 

14  IJK(I.J)  =  0 
KNLO  =  KNL1 

J2  =  J1  +  NBLTPH(NH)  -  1 
NTP  =  0 
IJ  =0 

CALL  HBELT  (J1 , J2 ,KNLO , 1) 

KHO  =  0 

KNLO  =  KNL1 

DO  15  NB=J1,J2 

IF  (NPTPLY(NB) .LE.O)  GO  TO  15 

NPTS  =  NPTPLY(NB) 

CALL  HSETC  (NPTS ,KHO , KNLO , NTP, IJ) 

KHO  =  KHO  +  NPTS 
KNLO  =  KNLO  +  NPTS 

15  CONTINUE 
KNLN  =  KNLO 

SET  UP  C  AND  IJK  ELEMENTS  FOR  TIE-POINTS. 


KNLO  =  KNL1 
KNLK  =  KNLO 
K1 

22 


DO 

IF 

K2 

DO 

KI 

KS 

IF 

KS1 

DO 

KK 

KI 

KS 

IF 

KS2 

IF 


+  1 

KNLK 

NB=J1 , J2 
(NPTPLY(NB) .LE.O)  GO  TO  22 
=  KI  +  NPTPLY(NB)  -  1 
21  KNL=K1,K2 
=  NL(l.KNL) 

=  IABS(IBAR(1 ,KI) ) 
(KS.LT.100)  GO  TO  21 
=  KS/100 
16  K=KNLK ,KNL 
=  K 

=  NL(1,K) 

=  IABS(IBAR(1,KD) 
(KS.LT.100)  GO  TO  16 


=  KS/100 
(KS2.EQ.KS1) 

16  CONTINUE 

17  IF  (KK.EQ.KNL) 


GO  TO  17 


GO  TO  21 


HPTURB 
HPTURB 
HPTURB 
HPTURB 
CHGIII 
HPTURB 
HPTURB 
HPTURB 
HPTURB 
HPTURB 
HPTURB 
HPTURB 
HPTURB 
HPTURB 
HPTURB 
HPTURB 
HPTURB 
HPTURB 
HPTURB 
HPTURB 
HPTURB 
HPTURB 
HPTURB 
HPTURB 
HPTURB 
HPTURB 
CHGI I I 
HPTURB 
HPTURB 
HPTURB 
HPTURB 
HPTURB 
HPTURB 
HPTURB 
HPTURB 
HPTURB 
HPTURB 
HPTURB 
HPTURB 
HPTURB 
HPTURB 
HPTURB 
HPTURB 
HPTURB 
HPTURB 
HPTURB 
HPTURB 
HPTURB 
HPTURB 
HPTURB 


=  KK  -  KNLO 
=  KNL  -  KNLO 
=  MAXO  ( 1  tKK2- 1 ) 

=  MINO (KK2+ 1 , KHO) 

18  IQ=IQ1,IQ2 

( I JK (XX2 , IQ) . EQ. 0)  GO  TO  18 
I JK (KK1 , IQ)  =  IJKtKKz , 10) 

I JK (KK2 , IQ)  =  0 
18  CONTINUE 


XX 1 
XX  2 
101 
IQ2 
DO 
IF 


0.0 

0.0 

1.0 

-1.0 


1 


GO  TO  29 


I JK (KK2 ,KK2)  =  IJ+1 
I JK(KK2 ,KK1)  =  I  J+2 
DO  20  J= 1 ,3 
DO  19  1=1,3 

C  ( I .  J .  IJ+1) 

19  C ( I , J , I J+2) 

C(J,J,IJ+1) 

20  C  (J , J , IJ+2) 

IJ  =  IJ  + 

21  CONTINUE 

XI  =  K2  + 

22  CONTINUE 
MJ2  =  - (KHO+NTP) 

IF  (NPRT (28) . LT . 3) 

NJ2  =  -MJ2 

DO  25  J= 1 ,NJ2 

(6,26)  J, (RHS(I.J) .1=1,3) , (IJX(J.I) ,I=1,NJ2) 
(I6,3F12.6,20I4/(42X,20I4)) 

KLM= 1 , I J 

(6,28)  KLM, ( (C (J , I , KLM) ,1=1,3) ,J=1,3) 
(I6.9F12.6) 

29  CALL  FSMSOL  (C ,RHS , I JK ,MJ2 , I J , 54 , 200) 

IF  (NPRT(28) .LT.3)  GO  TO  31 

DO  30  J= 1 ,NJ2 

30  WRITE  (6,26)  J , (RHS (I , J) , 1  =  1 ,3) , (I JK ( J , I)  ,  1  =  1  ,NJ2) 

31  ONE  =  1.0 
DELMAX  =0.0 
SCALE  =  1.0 

IT= 1 ,2 


25  WRITE 

26  FORMAT 
DO  27 

27  WRITE 

28  FORMAT 


DO  44 


XI  =  KO 

KH  =  0 

W: 

KR  =  NTP 

*y> 

DO  43  ; 

NB=J1,J2 
IF  (NPTPLY(NB) .LE.O)  GO  TO  43 
K2  =  XI  +  NPTPLY(NB)  -  1 
DO  42  K=X1,K2 

KH  =  KH  +  1 
1 


KR  =  KR  ♦ 


C 

C 

C 


HERE  X  IS  INDEX  OF  ALL  POINTS  IN  PLAY 

KH  IS  INDEX  OF  ALL  POINTS  IN  PLAY  ON  A  SINGLE  HARNESS 


HPTURB 

HPTURB 

HPTURB 

HPTURB 

HPTURB 

HPTURB 

HPTURB 

HPTURB 

HPTURB 

HPTURB 

HPTURB 

HPTURB 

HPTURB 

HPTURB 

HPTURB 

HPTURB 

HPTURB 

HPTURB 

HPTURB 

HPTURB 

HPTURB 

HPTURB 

HPTURB 

HPTURB 

HPTURB 

HPTURB 

HPTURB 

HPTURB 

HPTURB 

HPTURB 

HPTURB 

HPTURB 

HPTURB 

HPTURB 

HPTURB 

HPTURB 

HPTURB 

HPTURB 

HPTURB 

HPTURB 

HPTURB 

HPTURB 

HPTURB 

HPTURB 

HPTURB 

HPTURB 

HPTURB 

HPTURB 

HPTURB 

HPTURB 


KR  IS  INDEX  OF  RHS  ARRAY  ELEMENTS  HPTURB 

HPTURB 

KI  =  NL ( 1 ,K)  HPTURB 

KS  =  IABS(IBAR(1 , K I ) )  HPTURB 

IF  (KS.QT.100)  KS  =  MODIKS.IOO)  HPTURB 

IF  (IBAR(5,KI) .EQ.O)  GO  TO  HPTURB 

CALL  MAT31  (D(l . 1 ,KS) ,RHS(I ,KR) ,R)  HPTURB 

GO  TO  37  HPTURB 

HPTURB 

NOTE:  ENDPOINTS  (K  =  Kl  &  K2)  MUST  BE  TYPE  5.  HPTURB 

HPTURB 

32  CALL  DOT31  (E(l,l ,KH) ,RHS ( 1 ,KR) ,T1)  HPTURB 

IF  (IT.EQ.2)  GO  TO  33  HPTURB 

DELMAX  =  DMAX1 (DELMAX ,DABS (T1 (2) /DMINI (BB(K) ,BB(K- 1) ) ) )  HPTURB 

GO  TO  34  HPTURB 

33  BB(K  )  =  BB(K  )  ♦  SCALE*T1(2)  HPTURB 

BB(K-l)  «  BB(K-l)  -  SCALE*TI (2)  HPTURB 

34  DO  35  J= 1 , 3  HPTURB 

35  T2(J)  =  T1 (1)»E(J, 1 ,KH)  ♦  T1 (3) *E(J, 3,KH)  HPTURB 

CALL  MAT31  ( D ( 1 , I ,KS) ,T2 ,R)  HPTURB 

IF  (NPRT(28) .GE.3)  WRITE  (6,36)  K,T1,T2,R  HPTURB 

36  FORMAT  ( * 0 ’ . 16 ,3 (3X.3F12 . 6) )  HPTURB 

37  IF  (IT.EQ.2)  GO  TO  39  HPTURB 

DO  38  J=1 ,3  HPTURB 

38  DELMAX  =  DMAX1 (DELMAX, DABS (R(J) /DMAX1 (EPS(l) . DABS (BAR (J+3.KI) ))) )  HPTURB 

GO  TO  42  HPTURB 

39  DO  40  J=1 ,3  HPTURB 

40  BARIJ+3 ,KI)  =  BAR( J+3 ,KI)  +  SCALE»R(J)  HPTURB 

KE  =  IBAR(2 ,KI)  HPTURB 

IF  (KE.EQ.O)  GO  TO  42  HPTURB 

RER  *  XDY(BAR(4 ,KI) ,BD(7 ,KE) ,BAR(4 ,KI) )  HPTURB 

IF  (RER. LE. 1.0)  GO  TO  42  HPTURB 

SQRER  =  1 . O/DSQRT (RER)  HPTURB 

DO  41  J=  1 ,3  HPTURB 

41  BAR(J+3,KI)  =  SQRER*BAR(J+3 ,KI)  HPTURB 

42  CONTINUE  HPTURB 

Kl  =  K2  +  1  HPTURB 

43  CONTINUE  HPTURB 

IF  (IT.EQ.2)  GO  TO  44  HPTURB 

IF  (DELMAX. NE. 0.0)  SCALE  =  DMINI (ONE, EPS (1) /DELMAX)  HPTURB 

44  CONTINUE  HPTURB 

IF  (NPRT(28) .GE.2)  WRITE  (6,45)  I TER, DELMAX, SCALE  HPTURB 

45  FORMAT  CO  ITER  =’.16,'  DELMAX  =’ ,F15. 6, ’  SCALE  ** ,F15.6)  HPTURB 

LAST  =  DELMAX.LE.EPS (2)  .OR.  ITER. EQ. MAXI TB  HPTURB 

IF  (.NOT. LAST)  GO  TO  52  HPTURB 

KH  =  0  HPTURB 

Kl  =  KO  HPTURB 

HLOSS(l.NH)  =0.0  HPTURB 

HLOSS (2 ,NH)  =0.0  HPTURB 

DO  51  NB=J1,J2  HPTURB 


BLOSS (1,NB)  =0.0  HPTUBB 

BLOSS (2 ,NB)  =0.0  HPTURB 

IF  (NPTPLY(NB) .LE.O)  00  TO  51  HPTURB 

K2  =  Kl  +  NPTPLY(NB)  -  1  HPTURB 

KK1  =  NL(1,K1)  HPTURB 

KK2  =  NL ( 1 , K2 )  HPTURB 

DO  46  K=KK1 ,KK2  HPTURB 

DO  46  J= 1 ,3  HPTURB 

46  BAR(J+12,K)  =  0.0  HPTURB 

IF  (DHT.EQ.O.O)  GO  TO  49  HPTURB 

DO  48  K=K1 ,K2  HPTURB 

KH  =  KH  +  1  HPTURB 

KI  =  NL ( 1 ,K)  HPTURB 

PLOSS (2 ,KI  )  =  PLOSS (2 ,KI  )  ♦  DHT*PTLOSS (2 ,KH)  HPTURB 

IF  (K.EQ.K1)  GO  TO  47  HPTURB 

BBDOT(K-l)  =  (BB(K-l) -OLDBB(K-l) ) /DHT  HPTURB 

PLOSS (l.K-l)  =  PLOSS (l.K-l)  +  DHT»PTL0SS (1 ,KH-1)  HPTURB 

BLOSS ( 1 . NB )  =  BLOSS (l.NB)  ♦  PLOSS (l.K-l)  HPTURB 

47  DO  48  J= 1 , 3  HPTURB 

48  BAR(J+12,KI)  =  (BAR(J+3,KI) -BAR(J.KI) )/DHT  HPTURB 

BBDOT (K2)  =0.0  HPTURB 

PLOSS ( 1 ,K2)  =0.0  HPTURB 

49  Kl  =  K2+ 1  HPTURB 

DO  50  K=KK1 ,KK2  HPTURB 

50  BLOSS (2 ,NB)  =  BLOSS (2, NB)  ♦  PL0SS(2,K)  HPTURB 

HLOSS(l.NH)  =  BLOSS (1, KB)  *  BLOSS l l, KB)  HPTURB 

HLOSS (2 ,NH)  =  HLOSS (2 ,NH)  ♦  BLOSS (2, MB)  HPTURB 

51  CONTINUE  HPTURB 

52  IF  (NPRT(28) .EQ.O)  GO  TO  59  HPTURB 

IF  (.NOT. LAST  .AND.  IABS(NPRT(28) ) .EQ. 1)  GO  TO  59  HPTURB 

Kl  =  KO  HPTURB 

KH  =  0  HPTURB 

DO  57  NB=J1,J2  HPTURB 

IF  (NPTPLY(NB) .LE.O)  GO  TO  57  HPTURB 

WRITE  (6.53)  NB.NH  HPTURB 

53  FORMAT  (’0  BELT  NO. ’,14,’  OF  HARNESS  NO. ',14)  HPTURB 

K2  =  Kl  +  NPTPLY(NB)  -  1  HPTURB 

DO  54  K=K1 ,K2  HPTURB 

KH  =  KH  ♦  1  HPTURB 

KI  =  NL( 1 ,K)  HPTURB 

KS  =  IBAR(l.KI)  HPTURB 

BK  =  0.0  HPTURB 

IF  (K.NE.K1)  BK  =  BB(K-l)  HPTURB 

PLS  =  0.0  HPTURB 

IF  (K.NE.K1)  PLS  =  PLOSS ( 1 , K— 1 )  HPTURB 

T ( 1 )  =  BAR(4 ,KI)  HPTURB 

T (2)  =  BAR(5,KI)  HPTURB 

T (3)  =  BAR(6,KI)  HPTURB 

KJ  =  MOD(IABS(KS) .100)  HPTURB 

IF  (LPMI(KJ) .NE.O)  CALL  D0T31  (DPMI ( 1 , 1 ,KJ) ,BAR(4 ,KI) ,T)  HPTURB 


54  WBITE  (6,55)  K.KI .KS.BK.PLS, (T(J) ,J=1 ,3)  ,  HPTUBB 

*  (FCE(J.KH) ,J=1,3) ,PL0SS(2,KI)  HPTUBB 

55  FOBMAT  (318 ,F10. 3 ,F12.3 ,2X,3F9 . 3 .3X.3F11 . 3 .3X.F12. 3)  HPTUBB 

IF  (LAST)  WBITE  (6,56)  BLOSS ( I , MB) , BLOSS ( 2 , MB)  HPTUBB 

56  FOBMAT  (’0  TOTAL  BELT  ENEBGY  LOSS’ ,7X,F12.3,68X,F12.3)  HPTUBB 

XI  =  X2  ♦  1  HPTUBB 

57  CONTINUE  HPTUBB 

IF  (LAST)  WBITE  (6,58)  HLOSS ( 1 , NH) , HLOSS ( 2 , NH)  HPTUBB 

58  FOBMAT  (’0  TOTAL  HABNESS  ENEBGY  LOSS' ,7X,F12.3,68X,F12.3)  HPTUBB 

59  ITEB  =  ITEB  ♦  1  HPTUBB 

HPTUBB 

END  OF  DO  59  ITEB= 1 .MAXITB  LOOP  HPTUBB 

HPTUBB 

IF  (.NOT. LAST)  GO  TO  13  HPTUBB 

IF  ( ITEB. GT. MAXITB)  WBITE  (6,60)  MAXI TB, TSEC .DELMAX, SCALE  HPTUBB 

60  FOBMAT  (’0  HPTUBB  ITEB  =',14,'  AT  TIME  =',F8.3,  HPTUBB 

*  ’MSEC.  DELMAX  =’ ,F10. 6,’  SCALE  = ’ .F10.6)  HPTUBB 

J1  =  J2  +  1  HPTUBB 

KO  =  XI  HPTUBB 

KNLO  =  KNLN  CHGIII 

61  CONTINUE  HPTUBB 

IF  (NPBT(28) . LT.O)  NPBT(28)  =0  HPTUBB 

CALL  ELTIME  (2,39)  HPTUBB 

BETUBN  HPTUBB 

END  HPTUBB 
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SUBROUTINE  HSETC  ( NPTS , KHO , KNLO , NTP , I J )  HSETC 

C  REV  I I I. 2  08/08/84REVI I I 

IMPLICIT  REAL* 8  (A-H.O-Z)  HSETC 

COMMON/ SOMNTS/  D(3,3,30) ,WMEG(3,30) ,WMEGD(3,30) , U1 (3 . 30) ,U2(3,30) .HSETC 

*  SEGLP(3,30) , SEGLV(3,30) , SEGLA(3,30) ,NSYM(30)  HSETC 

COMMON/TABLES/MXNTI .MXNTB.MXTBl .MXTB2 ,NTI (50) ,NTAB(1250) .TAB (4500) DIMENB 
COMMON/HRNESS/  BAR ( 15 . 100) , BB ( 100) . BBD0T( 100) .PLOSS (2 . 100) .  HSETC 

*  XL0NG(20) .HTIME (2) , I BAR (5 ,100) ,NL(2 , 100) ,  HSETC 

»  NPTSPB(20) ,NPTPLY(20) ,NTHRNS(20) ,NBLTPH(5)  HSETC 

C  THIS  COMMON/TEMPVS/  IS  SHARED  BY  HPTURB ,  HBPLAY,  HBELT  AMD  HSETC.  HSETC 
COMMON/ TEMP  VS/  B  (3 , 3 , 3)  ,S  (3 ,3)  ,T  (3)  ,R  (3)  .  V  (3)  ,T1  (3)  ,T2  (3)  ,  HSETC 

*  E(3,3,50) ,ED0T(3,50) ,FCE(3,50) ,FR(3,50) ,ZR(3,50) ,  HSETC 

*  TR(3,50) ,U(3,50) .PTLOSS (2,50) ,BL(50) ,FB(50) ,FP(50) .HSETC 

*  OLDBB(IOO) ,RHS(3,54) ,C(3,3,200) ,IJK(54,54)  HSETC 

DIMENSION  KM(3) ,MK(2)  HSETC 

ONE  =  1.0  HSETC 

KNL  =  KNLO  HSETC 

KH  =  KHO  HSETC 

K1  =  KHO  +  NTP  +  1  HSETC 

K2  =  KHO  +  NTP  +  NPTS  HSETC 

DO  60  K=K1 ,K2  HSETC 

C  HSETC 

C  HERE  K  IS  INDEX  OF  IJK  AND  RHS  ARRAYS  HSETC 

KH  IS  INDEX  OF  POINTS  IN  PLAY  ON  EACH  HARNESS  HSETC 

KNL  IS  INDEX  OF  ALL  POINTS  IN  PLAY  HSETC 

KI  IS  INDEX  OF  ALL  POINTS  HSETC 

HSETC 

KH  =  KH  ♦  1  HSETC 

KNL  =  KNL  +  1  HSETC 

HSETC 

ZERO  C(K,K)  ,  C(K,K-1)  ,  C(K,K+1)  &  RHS(K);  SET  IJK(K.K)  =  IJ  HSETC 

HSETC 

KM( 1 )  =  K+l  HSETC 

KM(2)  =  K-l  HSETC 

KM(3)  =  K  HSETC 

IF  (K.EQ.K2)  KM ( 1 )  =  0  HSETC 

IF  (K.EQ.K1)  KM ( 2 )  =  0  HSETC 

KK  =  IJ  HSETC 

DO  12  L=  1 , 3  HSETC 

RHS(L.K)  =  0.0  HSETC 

IF  (KM(L).EQ.O)  GOTO  12  HSETC 

KK  =  KK+1  HSETC 

DO  11  1=1,3  HSETC 

DO  11  J= 1 , 3  HSETC 

11  C(I,J,KK)  =  0.0  HSETC 

12  CONTINUE  HSETC 

IJ  =  I J+ 1  HSETC 

I JK (K , K  )  =  IJ  HSETC 

HSETC 

COMPUTE  CNORM;  IF  ZERO,  SET  C(K,K)  =  I  HSETC 


o  u  o 


C  HSETC 

CNORM  =0.0  HSETC 

IF  (K.NE.X2)  CNORM  =  FB(KH) /BL(KH)  HSETC 

IF  (K.NE.K1)  CNORM  =  CNORM  +  FB (KH-1) /BL(KH-l)  HSETC 

KI  =  NL(1,XNL)  HSETC 

IF  (IABS(IBAR(1 ,KI) ) . GT. 100)  GO  TO  14  HSETC 

C  IF  (CNORM. NE. 0.0)  GO  TO  14  BUTLER 1 

XX  =  IJK(K,K)  HSETC 

DO  13  1=1,3  HSETC 

13  C(I,I,XX)  =  ONE  HSETC 

IF  (CNORM. EQ. 0.0)  GO  TO  60  BUTLER 1 

14  XX  =  IBAR(3 ,XI)  HSETC 

NFD  =  NTAB(KKd)  HSETC 

NFR  =  NTAB (XX+5)  HSETC 

HSETC 

SET  UP  B(3,3,3)  AND  S ( 3 . 3 )  HSETC 

HSETC 

MX ( 1 )  =  XH  HSETC 

MX  (2)  =  XH-1  HSETC 

IF  (K.EQ.K2)  MX(1)  =  0  HSETC 

IF  (X.FQ.X1)  MX(2)  =  0  HSETC 

DO  18  M=l,2  HSETC 

XX  =  MX  (M)  HSETC 

IF  (KK.NE.G  .AND.  CNORM. NE. 0.0)  GO  TO  16  HSETC 

DO  15  1=1,3  HSETC 

S ( I , M)  =  0.0  HSETC 

DO  15  J=1 ,3  HSETC 

15  Bd.J.M)  =  0.0  HSETC 

GO  TO  18  HSETC 

16  CALL  D0T31  (Ed  ,  1  ,XH)  ,U(1  ,XX)  ,T)  HSETC 

XIM  =  XNL  +  1  -  M  HSETC 

FBI  =  FB(XX) /BL(XX)  HSETC 

FB2  =  FP (XX) /BB (KIM)  -  FBI  HSETC 

FB3  =  FP (XX) *BL (XX) /BB (KIM)  **2  HSETC 

DO  17  1=1,3  HSETC 

SGN  =  ONE  HSETC 

IF  (FR(I.KH) .LT.O.O)  SGN  =  -ONE  HSETC 

S(I,M)  =  SGN* (FB3*T ( I ) )  HSETC 

DO  17  J= 1 ,3  HSETC 

17  B(I.J,M)  =  SGN* ( FB 1  * E ( J , I ,KH)  ♦  FB2*T(I) »U(J,KK) )  HSETC 

18  CONTINUE  HSETC 

DO  19  1=1,3  HSETC 

S(1 ,3)  =  - (S ( 1 . 1 )  +  S ( 1 , 2) )  HSETC 

DO  19  J=  1 ,3  HSETC 

19  B(I , J ,3)  =  - (B (I , J , 1 )  +  B(I ,J,2) )  HSETC 

IF  (NFR.EQ.O)  GO  TO  20  HSETC 

R(l)  =  TAB(NFR+2)  HSETC 

R (2)  =  TAB (NFR+4)  HSETC 

20  R(3)  =  0.0  HSETC 

DO  50  M=  1 , 3  HSETC 


M 

,*!»l**l 


SS 

$ 

Vi 

’:«&l 

1 ) 

$ 

•w 

,*y 


& 


L 
»w& 

oL 

;»»w 

$ 

$ 

iiS 


RH  =  0.0 
IF  (M.EQ.3) 

IF  (NFR.EQ.O) 


GO  TO  31 
GO  TO  48 


CONSTRAINTS  1  AND  2 

\ 

SGN  =  -ONE 

FR3  =  DABS (FR (M, KH) )  -  R(M) *DABS (FR(3 ,KH) ) 

IF  (IBAR(l.KI) .GT.O)  RH  =  FR3 
IF  (FR3.LE.0.0)  GO  TO  48 
GO  TO  40 

CONSTRAINT  NO.  3 

IF  (NFD.EQ.O)  GO  TO  48 
IF  (IBAR(l.KI) .LT.O)  GO  TO  40 
SGN  =  ONE 

RMAG2  =  TR( 1 , KH) »«2  +  TR(2,XH)**2  ♦  TB(3,KH)«»2 
RMAG  =  DSQRT (RMAG2) 

RER2  =  TR ( 1 , KH) *E ( 1 , 3 , KH) +  TB ( 2 , KH) *E ( 2 , 3 , KH) ♦  TR(3,KH)«E(3,3 
RER2  =  EDOT (3 ,KH) »RER2 
HER  =  DSQRT (RER2) 

PEN  =  RMAG/RER  •  RMAG 
RRDOT  =  BAR(4 ,KI ) »BAR( 13 ,KI) 

*  +  BAR(5,KI)»BAB<14,KI) 

*  +  BAR(6 ,KI) *BAR(15,KI) 

KS  =  IABS (IBAR( 1 ,KI) ) 

IF  (KS.GT.100)  KS  =  MOD(KS.IOO) 

CALL  D0T31  (D(l , 1 ,KS) , BAR(i3,KI) , T) 

ERDOT  =  E(1,3,KH)*T(1)  ♦  E(2,3,KH)*T(2)  ♦  E(3,3,KH)*T(3) 

Cl  =  PEN/RMAG2 

C2  =  RMAG»EDOT (3 ,KH) / (RER*RER2) 

PDOT  =  CURRDOT  -  C2»ERD0T 
NFDZ  =  IBAR(3 ,KI) 

CALL  FRCDFL  ( PEN, PDOT, NFDZ ,0,FDP, ELOSS) 

CALL  FRCDFL  ( PEN, PDOT, NFDZ, 1 ,FD  .ELOSS) 

RH  =  FD  ♦  FR(3,KH) 

PTL0SS(2,KH)  =  ELOSS 

Cl  =  FDP*C1 

C2  =  FDP*C2 

SGNB3  =  -DSIGN(0NE,FR(3 ,KH) ) 

DO  32  J= 1 , 3 

B(3, J,3)  =  SGNB3»B (3 , J , 3)  -  C1«TR(J,KH)  ♦  C2»E(J,3,KH) 

DO  47  LLs 1 , 3 
L  =  4  -  LL 

IF  (KM(L).EQ.O)  GO  TO  47 
DO  42  J=1 ,3 

V(J)  =  R(M) »B (3 , J ,L)  +  SGN*B(M, J.L) 

KL  =  KM(L) 

KML  =  KNL  +  KL  -  K 
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KIL  =  NLd.KML) 

IF  dBAR(5,KIL) .NE.O)  GO  TO  43 

KHL  =  KH  ♦  XL  -  X 

CALL  DOT31  (E( 1 , 1 ,KHL) ,V,T) 

T (2)  *  R(M)*S(3,L)  ♦  SGV«S(M,L) 

CALL  MAT31  (E(l , 1 ,KHL) ,T,V) 

43  IF  (LL.IIE.1)  GO  TO  44 

VE  =  V( I) #E(1 ,M,KH)  +  V(2) *E(2,M,KH)  +  V(3) *E(3,M,KH) 

EV  =  1.0 

IF  (IABS(IBAR(1,KI)) .LT.100) 

*  EV  =  DSIGN(ONE , VE) /DSQRT (V( 1)»*2*V(2)»»2*V(3)»»2) 

RH  =  EV*RH 

44  IF  (IJK(K.KL) .RE.O)  GO  TO  45 
IJ  =  IJ+1 

IJK(K.KL)  =  IJ 

45  KK  =  IJK(K.KL) 

DO  46  J=1 ,3 

VEV  =  EV«V(J) 

DO  40  1=1,3 

46  C(I,J,KK)  =  C(I.J.KK)  +  E ( I ,M,KH) *VEV 

47  CONTINUE 

DO  41  1=1,3 

41  RHS(I.K)  =  RHS(I.K)  ♦  RH«E(I ,M,KH) 

GO  TO  50 

48  IF  CIBARd  ,KI)  . LE.O)  GO  TO  50 
KK  =  I JK(K,K) 

DO  49  1=1,3 

DO  49  J=  1 ,3 

49  C(I.J.KK)  =  C(I,J,KK)  +  E(I ,M,KH)#E(J,M,KH) 

50  CONTINUE 
60  CONTINUE 

RETURN 
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SUBROUTINE  HYABF(B.Z.A.F) 
IMPLICIT  REAL»8 (A-H,0-Z) 


REV  IV 


CALCULATES  A,  AZ,  Z.AZ:  OLD  FORM  MUST  BE  DIAGONAL 

DIMENSION  B (24) ,Z(1) ,A(3,3) 

P2  =  0.0 

IF (B ( 1 ) .LT.0.0)P2  =  -BCD  -  2.0 
F  =  0.0 
DO  30  I  =  1,3 
J  =  I 

IF (B ( 1 ) . LT.O.OIGO  TO  10 
A ( 1 , 1 )  =  1 . 0/B ( I ) »*2 
GO  TO  15 

10  A ( 1 , 1 )  =  B ( I  + 16) 

J  =  J  ♦  1 

A(I,1)  =  HYFCN(A(I ,1) ,Z(I) ,B(J) ,P2) 
IF(P2.GT.0.0)A(I,1)  =  A( I , 1 ) »DABS (Z (I) /B(J) ) »»P2 
15  DO  20  J  =  2,3 
20  A ( I , J)  =  A ( I , J-l) »Z(I) 

30  F  =  F  +  A(I, 3) 

RETURN 

END 
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SUBROUTINE  HYBND(M,Z , IV.U.C , X) 
IMPLICIT  REAL»8 (A-H.O-Z) 


REV  IV 


C  SEARCHES  FOR  POINT  NEAREST  CORNER  -  DIRECTION  C*U 
C 

DIMENSION  Z (3 , 12) , IV ( 12) ,U(3) ,X(3) 

DO  20  I  =  1 ,M,2 
J  =  IV(I) 

ATST  =  C*(U(1)»Z(1,J)  ♦  U(2)*Z(2,J)  ♦  U(3)«Z(3,J)) 

IFd.EQ.DGO  TO  10 

TEST  =  AMAX  -  ATST 

COMP  =  DMAX1 (DABS (AMAX) .DABS (ATST)) 

C  PRECISION  TEST  -  TRY  >1000?? 

IF ( 1000 . »DABS (TEST) .LT.COMPJTEST  *  0.0 
IF (TEST) 10,15,20 
C  IF (AMAX-ATST) 10,15,20 
10  AMAX  =  ATST 
J1  =  J 
15  J2  =  J 
20  CONTINUE 

DO  25  I  =  1.3 

25  X(I)  =  0 . 5* (Z (I , Jl)  +  Z ( I , J2) ) 

RETURN 

END 
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SUBROUTINE  HYBOXfE ,T ,P ,N ,Z , I V) 


IMPLICIT  REAL*8 (A-H ,0-Z) 


REV  IV 


COMPUTES  THE  INTERSECTION  OF  A  PLANE  WITH  THE  EDGES  OF  A  BOX 


ft 


DIMENSION  T (3) ,E(3) .TU(3) ,T2(3) ,P(3) 
C  TO  BE  SAFE  IV  AND  Z  SHOULD  BE  DIMENSION 
DIMENSION  I V ( 1 2 ) 

DIMENSION  Z(3, 12) 

DATA  ONE/l.ODO/ 

C  T  -  PLANE  VECTOR,  P  POINT  IN  PLANE 
TUV  =  0.0 
DO  10  I  =  1,3 
TU(I)  =  T ( I ) »E (I ) 

T2 ( I )  =  2 . 0»TU ( I ) 

10  TUV  =  TUV  +  T  (I) « (Ed)  ♦  P(I) ) 


DO  45  I  =  1.3 
CK  =  -E (K) 

PI  =  TUV 
DO  40  LL  =  1.2 
P2  =  PI  -  T2(I) 

P3  =  P2  -  T2(J) 

P4  *  PI  -  T2(J) 

M  =  N 

I F ( DS I GN ( ONE , P2 ) .EQ.DSIGN(ONE.Pl) )G0 
M  =  M  +  1 

Z ( I . M)  =  (P1/TU(I)  -  1 .0) »E(I) 

Z(J,M)  =  -E(J) 

Z (K ,M)  =  CK 

15  IF (DSIGN (ONE ,P3) . EQ. DSIGN (ONE ,P2) )G0 
M  =  M  +  1 
Z(I.M)  =  E(I) 

Z ( J , M)  =  (P2/TU ( J)  -  1 . 0) *E (J) 

Z(K.M)  =  CK 

20  IF(DSIGN(ONE,P3) . EQ. DSIGN (ONE. P4) ) GO 
M  =  M  +  1 

Z(I.M)  =  (P4/TU ( I )  -  1 .0) *E(I) 

Z(J.M)  =  E(J) 

Z (K ,M)  =  CK 

25  IF (DSIGN (ONE. P4) .EQ.DSIGN(ONE.Pl)  )GO 
M  =  M  +  1 
Z(I.M)  =  -Ed) 

Z(J,M)  =  (P1/TU( J)  -  1 . 0) »E (J) 

Z(K.M)  =  CK 
30  IF (M. EQ. N) GO  TO  35 
CHECK  FOR  PRECISION  (+-+-. OR  -+-+) 


14  IN  CALLING  PROGRAM 


TO  15 


TO  20 


TO  25 


TO  30 
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IF (M. EQ. N+4) GO  TO  35 
C  DELETE  0  LENGTH  SIDE 

IF( (Z(I ,M-1) .EQ.Z(I,M)) .AND. (Z(J.M-l) .EQ.Z(J,M) ) )GO  TO  35 
N  =  M 

35  PI  =  PI  -  T2(K) 

40  CK  =  -CK 
J  =  K 
45  K  =  I 


IF (N. LT . 6)GO  TO  65 
IV ( I )  =  1 
IV (2)  =  2 
M  =  2 

DO  60  J  =  3,N,2 


D  =  DABS (Z ( I , M) )  +  DABS (Z (2 ,M) )  ♦  DABS(Z(3,M)) 

DO  55  L  =  3 ,N 
DO  50  LL  =  2,J 
IF(IV(LL-1) . EQ.L)  GO  TO  55 
50  CONTINUE 

F  =  DABS (Z ( 1 ,M) ~Z ( 1 ,L) ) +DABS (Z (2  f M) -Z (2 ,L) ) +DABS ( Z ( 3 , M) —  Z ( 3 , L ) ) 
IF (F.GT.D)GO  TO  55 
D  =  F 
K  =  L 

55  CONTINUE 
M  «  K  +  1 

IF (MOD (K ,2) . EQ.O)M  =  K  -  I 
IV(J)  =  K 
IV(J+1)  =  M 
60  CONTINUE 
65  RETURN 
END 
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SUBROUTINE  HYDAD(D,A,DAD5 
C 

IMPLICIT  REAL*8(A-H,0-Z) 

COMPUTES  D’A(*,1)D 

DIMENSION  D (3 , 3) ,A(3) ,DAD(3,3) 

DO  10  I  =  1,3 
DO  10  J  =  1,3 
DAD (I , J)  =  0.0 
DO  10  K  *  1.3 

10  DAD ( I , J)  =  DAD(I.J)  +  D(K,I)»A(K)»D(K,J) 
RETURN 
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SUBROUTINE  HYEST (BM.BN.TAB) 

C 

C  LINEAR  PROGRAM 

IMPLICIT  REAL»8 (A-H.O-Z) 

DIMENSION  BM(24) ,BN(24) ,TAB(8) 
COMMON/TEMPVS/DI 2 (3,3) ,A(3,3) ,B(3,3) ,XMN(3) 
*  T(3) ,R(3) , C (3 ,3) ,V(7) 

C  R  GOES  FROM  M  TO  N  D12  =  DM«DN* 

C  R  =  0  CANNOT  BE  SOLVED  WITH  THIS  METHOD 
BE  =  1.0 

RR  =  R( 1) **2  +  R(2)«*2  +  R(3)»«2 
IF (RR.EQ. 0 . 0) GO  TO  30 
C  R.R  =  0  INVALID 
M  =  1 
N  =  1 

IF (BM( 1) . LT.0.0)M  =  2 
IF(BN ( 1 ) .LT. 0.0)1  =  2 
PM  =  2. 

PN  =  2. 

IF (M. EQ. 2) PM  =  - BM ( 1 ) 

IF (N. EQ. 2) PN  =  -BN( 1) 

DO  10  I  =  1,3 
T(I)  =  R(I) 

DO  10  J  =  1,3 
10  B(I.J)  =  D12( I.J) 

IF (N. EQ. 2) CALL  DOTT33 (D12 ,BM(8) ,B) 

DO  15  I  =  1,3 
DO  15  J  =  1,3 
15  C Cl , J)  =  B(I,J) 

IF (M. EQ . 2) CALL  MAT33 (BM(8) ,B ,C) 

C  C  WILL  TRANSFORM  FROM  NN  TO  MM 

IF (M.EQ. 21CALL  MAT31 (BM(8) ,R,T) 

CALL  HYLPX(BM(M) ,BN(N)) 

BE  =  V (7) 

IF (V (7) .LE. 1 .0)G0  TO  30 
CALL  HYABF(BM(1) ,V(1) , A.F1) 

CALL  HYABF(BN(1) ,V(4) ,B,F2) 

C  ESTIMATE  ALPHA 

AA  =  Ad  ,2)  **2  +  A  (2 , 2)  »*2  ♦  A(3,2)«*2 
BB  =  B ( 1 , 2) **2  +  B (2 ,2) »*2  +  B(3,2)»*2 
ALP  =  DSQRT (AA/B3) 

RA  =  Fl«* (1 . O/PM) 

RB  =  F2*« ( 1 . O/PN) 

ALP  =  ALP»RA»F2/(RB*F1) 

C  SCALE  POINTS  TO  ELLIPSOIDS 
DO  20  I  =  1,3 
V  ( I )  =  V(I)/RA 

20  V ( I  +  3 )  =  V(I+3) /RB 
C  ESTIMATE  BETA 

CALL  MAT31 (C , V(4) ,T) 


REV  IV 


,RLM(3) ,XMM(3) 
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BE  =  (V(l)-T(D)  »»2  ♦  ( V  ( 2 )  -T  (2) )  »»2  ♦  (V(3)  -  T(3))**2 
BE  =  DSQRT (BE/RB) 

STORE  VALUES  IN  TAB  ARRAY  FOB  CONTACT 
TAB ( 1 )  =  ALP 
DO  25  I  =  1,6 
25  TAB'(I+2)  =  V( I) 

30  TAB (2)  =  BE 
RETURN 
END 
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DOUBLE  PRECISIOIJ  FUNCTION  HYFCNfC ,Z , A.P) 


REV  IV 


IMPLICIT  REAL*8 (A-H.O-Z) 
HYFCN  =  C 

IF(P.EQ.O.O)GO  TO  10 
HYFCN  =0.0 
IF(Z.E Q. 0.0)00  TO  10 
Q  =  P* (DL0G(DABS (Z) ) 

IF (Q.  GT. -88 . 5)  HYFCN 
10  RETURN 
END 
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C»DEXP (Q) 
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SUBROUTINE  HYLIM(A.U.B,V,C,W,Z,BD) 

HYLIM 

REV  IV 

12/ 1 1/87HYFIX 

IMPLICIT  REAL»8 (A-H.O-Z) 

HYLIM 

GIVEN  Z,  FIND  A,B,Z:  ZEZ  =  1.  ZEV  =0.  TZ  *  TP 

HYLIM 

DIMENSION  BD (24) 

HYLIM 

DIMENSION  U(3) ,V(3) ,W(3) ,EI(3) ,EJ(3) ,T(3) ,TV(3) 

HYLIM 

DIMENSION  Z(3) ,E(3) ,EV(3) ,Q(3) ,S(3) ,EZ(3) 

HYLIM 

DIMENSION  SM(3 , 3) 

HYLIM 

LOGICAL  PASS, USEV 

HYLIM 

PASS  =  .FALSE. 

HYLIM 

ITER  =  100 

HYLIM 

PP  =  - 1 . /BD ( 1 ) 

HYLIM 

POW  =  -BD(1)  -  2.0 

HYLIM 

PI  =  -BD( 1)  -  1.0 

HYLIM 

POl  =  1.0/PI 

HYLIM 

P2  =  -BD(1)/P1 

HYLIM 

DO  10  I  =  1.3 

HYLIM 

TV(I)  =  0.0 

HYLIM 

10  IF(V(I)  .NE.O.O)TV(I)  =  HYFCNd.O/Vd)  , V ( I )  ,BD(I  +  1)  ,P2) 

HYFIX 

GET  RECIPROCAL  SET 

HYLIM 

CALL  CROSS(V.W.EI) 

HYLIM 

CALL  CROSS(W.U.EJ) 

HYLIM 

CALL  CROSS (U.V.T) 

HYLIM 

EIU  =  El ( 1) *U( 1)  ♦  EI(2)«U(2)  ♦  El (3) *U (3) 

HYLIM 

G  =  C*EIU 

HYLIM 

1C  HYLIM 

DO  55  IT  =  l.ITER  HYLIM 

EVM  =  0.0  HYLIM 

EVZ  =  0.0  HYLIM 

ZEZ  =0.0  HYLIM 

USEV  =  .FALSE.  HYLIM 

DO  15  I  =  1,3  HYLIM 

E(I)  =  HYFCN(BD(I*16) ,Z(I) ,BD(I*1) ,POW)  HYLIM 

EV  Cl)  =  E(I) *V(I)  HYLIM 

IF (EV(I ) . EQ. 0 . 0) USEV  *  .TRUE.  HYLIM 

IF(DABS(EY(I) ) .GT. EVM) EVM  =  DABS(EV(I) )  HYLIM 

#  EZ(I)  =  E(I)»Z(I)  HYLIM 

IIF(DABS(EZ(I) ) .GT. EVZ) EVZ  =  DABS(EZ(I) )  HYLIM 

15  ZEZ  =  ZEZ  ♦  Z ( I ) *EZ (I)  HYLIM 

RHO  =  ZEZ»*PP  HYLIM 

DO  20  I  =  1,3  HYLIM 

20  Z(I)  =  Z ( I ) /RHO  HYLIM 

•  IF (PASS) GO  TO  60  HYLIM 

rro  RHOZ  =  ZEZ/RHO  HYLIM 

5$  RHOV  =  EVM* RHOZ /RHO  HYLIM 

fSC  RHOZ  =  EVZ*  RHOZ  HYLIM 

fgH  IF (.HOT. USEV) GO  TO  30  HYLIM 

gfl  RHOV  =  1.0  HYLIM 

#  DO  25  I  =  1.3  HYLIM 

gg  25  EV(I)  *  TV (I)  HYLIM 


C  WHAT  IF  HO  TV  IS  0  AMD  EV  ABE  ALL  0  ?  HYLIM 

30  DO  35  I  =  1,3  HYLIM 

EV(I)  =  EV ( I ) /RHOV  HYLIM 

35  EZ(I)  =  EZ (I) /RHOZ  HYLIM 

C  SET  UP  MATBIX  HYLIM 

CALL  CBOSS(EV,  T.SM(I.l))  HYLIM 

CALL  CBOSS(T  ,EZ,SM(1,2))  HYLIM 

CALL  CBOSS (EZ,EV,SM(1 ,3) )  HYLIM 

TZV  =  T( 1) *SM( 1 ,3)  ♦  T ( 2 ) *SM(2 ,3)  ♦  T(3)»SM(3,3)  HYLIM 

TZ  =  T ( 1 ) *Z ( 1 )  +  T(2)»Z(2)  ♦  T (3) *Z (3)  HYLIM 

ZEV  =  Z(1)*EV(1)  ♦  Z(2)»EV(2)  ♦  Z(3)»EV(3)  HYLIM 

IF (TZV. EQ. 0.0) STOP  30  HYLIM 

ZEV  =  ZEV/TZV  HYLIM 

Q(l)  =  0.0  HYLIM 

0(2)  =  -ZEV  HYLIM 

IF ( . HOT.USEV)Q(2)  =  Q(2)/P1  HYLIM 

Q(3)  =  (G  -  TZ) /TZV  HYLIM 

CALL  MAT31 (SM,Q ,S)  HYLIM 

SS  =  0.0  HYLIM 

ZZ  =  0.0  HYLIM 

DO  50  I  =  1.3  HYLIM 

SS  =  SS  +  DABS(S(I) )  HYLIM 

IF (DABS (Z ( I ) ) . LT . 0 . 1»BD( 1+ 1) ) GO  TO  45  HYLIM 

IF (DABS (S (I) ) . GT.DABS(Z(I) ) )S(I)  *  DSIGi(0 . 5*Z(I) ,S (I) )  HYLIM 

45  Zd)  =  Zd)  +  S(I)  HYLIM 

IF (DABS (Z(I)) . GT . BD ( 1+ 1) )Z (I)  *  DSIGH(BD(I+1) ,Z(I) )  HYLIM 

50  ZZ  =  ZZ  *  DABS (Z (I ) )  HYLIM 

IF (SS.LT. 1 . 0E-10*ZZ) PASS  =  .TBUE.  HYLIM 

55  CONTINUE  HYLIM 

C  HYLIM 

60  A  =  (El ( 1) «Z( 1)  +  El (2) *Z (2)  +  El (3) *Z(3) ) /EIU  HYLIM 

B  =  (EJ(1)«Z(1)  +  EJ (2) *Z(2)  ♦  EJ (3) *Z(3) ) /EIU  HYLIM 

BETUBN  HYLIM 

END  HYLIM 


SUBROUTINE  HYLPR(J1 ,J2, ID.C.S.E.T) 

C  REV  IV 

IMPLICIT  REAL»8 (A-H.O-Z) 

DIMENSION  ID ( 16) ,C(16) ,S(9,8) ,E(9) ,T(7) 

C  LINEAR  PROGRAM  ROUTINE  USING  SIMPLEX  METHOD 
C  J1  =  J2  FORCED  PIVOT  ON  COLUMN  J1 
CALCULATE  COSTS 
J  =  JI 

IF ( J . EQ . J2) GO  TO  30 
10  DO  20  L  =  1.7 
T(L)  =  -C(L) 

IF (C (L) .EQ. 10.1GO  TO  20 
DO  15  I  =  1,9 

15  T(L)  =  T(L)  +  S (I ,L) *C (1+7) 

20  CONTINUE 

I F ( J 1 .EQ. J21G0  TO  65 
C  FIND  PIVOT  COLUMN 
DO  25  L  =  1,7 
J  =  L 

IF  CT (L)  . GT .  0 . 0 ) GO  TO  30 
25  CONTINUE 
GO  TO  65 

C  FIND  PIVOT  ROW 
30  K  =  0 

DO  40  I  =  1,9 
C  SAVE  PIVOT  COLUMN 
E(I)  =  S (I . J) 

IF(S(I.J) . LE . 0 . 0 ) GO  TO  40 
I F ( K . EQ . 0 ) GO  TO  35 
IF (S ( I , 8) .GE. Z«S (I , J) )G0  TO  40 
35  K  =  I 

Z  =  S ( 1 ,8) / S ( I  ,J) 

40  CONTINUE 
C  REPLACE  COLUMNS 

IF (K. EQ. 0) GO  TO  65 
M  =  ID ( J) 

ID ( J)  =  ID (K+7) 

ID (K+7)  =  M 
Q  =  C(J) 

C ( J)  =  C (K+7) 

C (K+7)  =  Q 
P  =  S(K, J) 

DO  45  I  =  1.9 
45  S(I.J)  =  0.0 
S(K.J)  =  1.0 
DO  50  L  =  1,8 
50  S(K,L)  =  S(K,L)/P 
E(K)  =  1.0 
DO  60  I  =  1,9 
IF(I.EQ.K)GO  TO  60 
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IF(E(I) . EQ.O.O)GO  TO  60 
DO  55  M  =  1,8 

55  S  ( I ,  M)  =  S  ( I ,  M)  -  E(I)*S(K,M) 
60  CONTINUE 
GO  TO  10 
65  RETURN 
END 
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SUBROUTINE  HYLPX CBM, BN)  HYLPX 

REV  IV  02/07/87HYLPX 

LINEAR  PROGRAM  EXEC  HYLPX 

IMPLICIT  REAL»8 (A-H.O-Z)  HYLPX 

DIMENSION  BM(23) ,BN(23)  HYLPX 

C0MM0N/TEMPVS/DI2 (3 , 3) ,P(3,3) ,Q(3,3) .XMNC3) ,RLN(3) ,XMM(3) .  HYLPX 

*  R(3) ,H(3) , D  C  3 , 3 ) ,V(7) ,S(9,8) ,C(16) , A (7 ) ,B(3) ,  HYLPX 

*  E(9) ,T(7) ,ID(16)  ,IP(2)  HYLPX 

CALL  MAT31 (D,BN,B)  HYLPX 

DO  10  I  =  1,3  HYLPX 

B ( I )  =  BM(I)  -  B ( I )  ♦  R (I )  HYLPX 

A ( I )  =  BM(I)  HYLPX 

10  ACI+3)  =  BN ( I )  HYLPX 

A  ( 7)  =  -1.0  HYLPX 

DO  15  I  =  1,16  HYLPX 

C(I)  =  0.0  HYLPX 

15  ID (I)  =  I  HYLPX 

C(7)  =  -1.0  HYLPX 

DO  20  I  =  1,9  HYLPX 

DO  20  J  =  1,8  HYLPX 

20  S ( I , J)  =  0.0  HYLPX 

HYLPX 

0STS  0  0-1  HYLPX 

I  -D  -R  A  -  DB  +  R  (>0)  IMF  COST  HYLPX 

I  0  0  2A  HYLPX 

0  I  0  2B  HYLPX 

HYLPX 

DO  25  I  =  1,6  HYLPX 

25  S (1+3 , I )  =  1.0  HYLPX 

DO  30  I  =  1,3  HYLPX 

C(I+7)  =  10.  HYLPX 

S(I,7)  =  -R(I)  HYLPX 

SCI,  I)  =  1.0  HYLPX 

SCI, 8)  =  BCI)  HYLPX 

SC  1+3, 8)  =  2 . 0*A ( I )  HYLPX 

S (1+6 ,8)  =  2 . 0*A( 1+3)  HYLPX 

DO  30  J  =  1,3  HYLPX 

30  SCI.J+3)  =  -DCI.J)  HYLPX 

CHECK  SIGN  OF  RHS  HYLPX 

DO  40  I  =  1,3  HYLPX 

IFCBCI) .GE.0.01G0  TO  40  HYLPX 

DO  35  J  =  1,8  HYLPX 

35  SCI , J )  =  -S  ( I ,  J )  HYLPX 

40  CONTINUE  HYLPX 

s  1  HYLPX 

J2  =  7  HYLPX 

c  HYLPX 

CALL  HYLPRCJl ,J2,ID,C,S,E,T)  HYLPX 

NK  =  0  HYLPX 
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COUNT  ZEROES  IN  SOLUTION 
DO  45  I  =  1,7 

C  TEST  SHOULD  PROBABLY  BE  AN  EPSILON  TEST.  DABS (T (I) ) . GT.EPS 
IF ( (T ( I) . NE. 0 . 0) .OR. (C(I) . EQ. 10 . ) ) GO  TO  45 
NZ  =  NZ  +  1 
IP(NZ)  =  I 
45  CONTINUE 
C  SET  PASS  COUNT 
NP  =  1 

IF(NZ.GT.O)NP  =  2**NZ 
C 

DO  55  M  =  1 , NP 
NM  =  NK 
NK  =  NK  ♦  1 
DO  50  I  =  1,16 
K  =  ID  (I) 

IF(K.GT.7)GO  TO  50 
W  =  0.0 

I F ( I . GT . 7 ) W  =  S (1-7 ,8) 

V (K)  =  (W  -  A (K)  +  NM*V(K))/NK 
50  CONTINUE 

C  LOOK  FOR  ALL  SOLUTIONS 
IF (M.EQ.NP)GO  TO  55 
J1  =  IP ( 1) 

IP ( 1)  =  IP (2) 

IP (2)  =  J1 

IF (T (Jl) . NE . 0 . 0 ) GO  TO  55 
J2  =  Jl 

CALL  HYLPR(J1 ,J2,ID,C,S,E,T) 

55  CONTINUE 
RETURN 
END 
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SUBROUTINE  HYNTR<BM,BN,TAB)  HYNTR 

C  REV  IV  02/07/87HYNTR 

IMPLICIT  REAL*8 (A-H.O-Z)  HYNTR 

CALCULATIONS  IN  SEGMENT  M’S  REFERENCE  HYNTR 

DIMENSION  BM(24) ,BN(24) ,TAB(8)  HYNTR 

COMMON/TEMPVS/D12 (3 , 3) ,A(3,3) ,B(3,3) ,XMN(3) ,RLN(3) ,XMM(3) ,  HYNTR 

*  AZ(3)  ,R(3)  , Z ( 3)  ,DNM(3,3)  , DADO, 3)  ,DBD(3,3)  ,  HYNTR 

»  BMD(3,3) ,TMP(3,3) ,S(5,6) ,ZVR(3) ,BZV(3) ,V(3) ,  HYNTR 

*  ZM(3) ,VN(3) ,F(2) ,BV(3)  HYNTR 

PI  =  2.0  HYNTR 

P2  =  2.0  HYNTR 

IF(BM(1) . LT . - 2 . 0 ) P 1  =  -BM( 1)  HYNTR 

IF (BN( 1 ) .LT.-2.0)P2  =  -BN(1)  HYNTR 

Cl  =  PI  -  1.0  HYNTR 

CN  =  P2  -  1.0  HYNTR 

C  DNM  TRANSFORMS  FROM  M  TO  NN  HYNTR 

K  =  8  HYNTR 

DO  15  J  =  1,3  HYNTR 

DO  10  I  =  1,3  HYNTR 

BMD(I,J)  =  0.0  HYNTR 

IF (BM( 1 ) . LT. 0 . 0) BMD  (I , J)  =  BM(K)  HYNTR 


DNM(I.J)  =  D 1 2 ( I , J)  HYNTR 

10  K  =  K  ♦  1  HYNTR 

15  IF(BM(1) . GT . 0 . 0) BMD ( J , J)  =  1.0  HYNTR 

I F ( BN ( 1 ) . LT . 0 . 0 ) CALL  D0TT33(BN(8) , D12.DNM)  HYNTR 

ALP  =  TAB ( 1 )  HYNTR 

BET  =  TAB (2)  HYNTR 

DO  20  I  =  1,3  HYNTR 

ZM( I )  =  TAB ( I ♦ 2 )  HYNTR 

20  VN( I )  =  TAB ( I  +  5 )  HYNTR 

C  PUT  VECTORS  INTO  VS  REFERENCE  HYNTR 

CALL  D0T31 (BMD ,ZM,Z)  HYNTR 

CALL  D0T3I (DNM,VN,V)  HYNTR 

DO  25  I  =  1,3  HYNTR 

25  ZVR(I)  =  Z ( I )  -  V(I)  -  BET»R(I)  HYNTR 

C  HYNTR 

DO  40  ITER  =  1,100  HYNTR 

CALL  HYABF (BM.ZM, A ,F ( 1) )  HYNTR 

CALL  HYABF (BN, VN,B ,F (2) )  HYNTR 

CALL  DOT31 (BMD, A( 1,2) ,AZ)  HYNTR 

CALL  DOT31 (DNM, B( 1,2) ,BV)  HYNTR 

CALL  HYD AD ( BMD , A , D AD )  HYNTR 

CALL  HYD AD ( DNM , B , DBD )  HYNTR 

CALL  MAT31 (DBD.R.S (1,5))  HYNTR 

CALL  MAT31 (DBD.ZVR.BZV)  HYNTR 

C2  =  CN*ALP  HYNTR 

C  SET  UP  S  MATRIX  HYNTR 

S (4 , 4)  =  0.0  HYNTR 

S (5 , 5)  =  0.0  HYNTR 


S(4 ,6)  =  (1.0  -  F(2))/P2  - V ( 1 ) *BZV( 1 )  -V(2)*BZV(2)  -V(3)*BZV(3)  HYNTR 
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S (5 ,6)  =  (1.0  -  F(1))/P1 

HYNTR 

S(4 .5)  =  -BVC 1) *R( 1)  - 

BV(2)»R(2)  -  BV (3) *R(3) 

HYNTR 

S (5 ,4)  =  0.0 

HYNTR 

DO  30  I  =  1,3 

HYNTR 

S (I ,4)  =  BV(I) 

HYNTR 

S (4 , 1)  =  BV(I ) 

HYNTR 

S(I ,5)  =  -C2*S (I ,5) 

HYNTR 

S (5 , I)  =  AZ(I) 

HYNTR 

S(I ,6)  =  -AZ(I)  -  ALP»BV(I)  -  C2»BZV(I) 

HYNTR 

DO  30  J  =  1.3 

HYNTR 

SCI , J)  =  C1»DAD(I,J)  + 

C2*DBD(I , J) 

HYNTR 

CALL  HYSOL (S , 5 ,5) 

HYNTR 

TALP  =  ALP  +  S (4 ,6) 

HYNTR 

IF (TALP.LE.O.O)TALP  = 

ALP/2.0 

HYNTR 

ALP  =  TALP 

HYNTR 

TBET  =  BET  +  S(5,6) 

HYNTR 

IF (TBET. LE . 0 . 0)TBET  = 

BET/2.0 

HYNTR 

BET  =  TBET 

HYNTR 

SS  =  0.0 

HYNTR 

ZZ  =  0.0 

HYNTR 

DO  35  I  =  1,3 

HYNTR 

SS  =  SS  +  DABS(S(I ,6) ) 

HYNTR 

Z(I)  =  Z(I)  +  S(I ,6) 

HYNTR 

ZZ  =  ZZ  ♦  DABS(Z(I) ) 

HYNTR 

V(I)  =  Z(I)  -  BET*R(I) 

HYNTR 

ZVR(I)  =  0.0 

HYNTR 

CALL  MAT31 (BMD.Z.ZM) 

CALL  MAT31 (DNM, V, VN) 

CONVERGENCE  TEST  DEPENDS  ON  REAL*4  (1.0E-5)  OR  REAL*8  (?? 
IF (SS . LT . 1 . OE- 10*ZZ) GO  TO  50 
K  *  1 
L  =  I 

IF (BM( 1) . LT . 0 . 0 ) K  =  2 
IF(BN(1) .LT.O.OIL  =  2 
DO  37  I  =  1,3 

IF (DABS (ZM(I) ) .GT . BM(X) )  ZM(I)  =  DSIGN(BM(K) ,ZM(I) ) 
IF (DABS (VN (I ) ) . GT . BN(L) )  VN<I>  =  DSIGN(BN(L) ,VN(I)) 
K  =  K  +  1 

37  L  =  L  +  1 

CALL  D0T31 (BMD.ZM.Z) 

CALL  D0T31 (DNM.VN, V) 

DO  38  I  =  1,3 

38  ZVR(I)  =  Z(I)  -  V(I)  -  BET#R(I) 

40  CONTINUE 

C  WRITE (6 , 45) 

C  45  FORMAT ( '  HYNTR  DID  NOT  CONVERGE,  CONTACT  IGNORED.’) 
BET  =  1.0 
50  TAB (1)  =  ALP 
TAB (2)  =  BET 
DO  55  I  -  1,3 
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DOUBLE  PRECISION  FUNCTION  HYPEN(BD,E, V) 

REV  IV 

POINT  OF  MAXIMUM  PENETRATION 
SOLVES  FOR  VALUE  OF  ALP  USED  BY  PLELP 
POWERS  OF  HYPERELLIPSOID  MAY  BE  DIFFERENT 
IMPLICIT  REAL*8(A-H,0-Z) 

DIMENSION  BD(24) ,E(3) ,V(3) 

FX(A)  =  A**E( 1) *V( 1) +A**E(2) *V(2) +A**E (3) *V (3)  —  1 . 0 
L  =  1 
VM  =  V(l) 

DO  10  I  =  2,3 
IF  (V(I).LE.VM)  GO  TO  10 
L  =  I 
VM  =  V ( I) 

10  CONTINUE 

A  =  V( 1)  ♦  V ( 2 )  ♦  V (3) 

A  =  1 . 0/A*» ( 1 . 0/E (L) ) 

DEL  =  A/2.0 
AP  =  0.0 
12  F  =  FX (A) 

IF  (DABS(F) .LT. l.D-Ofl)  GO  TO  40 
IF  (F)  16,40,14 

14  IF  (A-DEL.LE.O.O)  DEL  -  A/2.0 
AP  =  A 
FP  =  F 
A  =  A  -  DEL 
GO  TO  12 

16  IF  (AP.NE.O.O)  GO  TO  18 
A  =  A  +  DEL 
GO  TO  12 
18  AM  =  A 
FM  =  F 

20  IF  (FP.EQ.FM)  GO  TO  40 

DEL  =  -FM* (AP  -  AM) / (FP  -  FM) 

AN  =  AM  +  DEL 
IF  (AN.EQ.A)  GO  TO  40 
A  =  AN 
F  =  FX(A) 

IF  (DABS(F) .LT. l.D-08)  GO  TO  40 
IF  (F)  18,40,22 
22  FP  =  F 
AP  =  A 
GO  TO  20 
40  HYPEN  =  A 
RETURN 
END 
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SUBROUTINE  HYBEA  (L.H.AREA.AB.BB)  H7FIX 

BE?  I?  12/11/87HYFIX 

IMPLICIT  REAL*8 ( A-H.O-Z)  HYREA 

DIMENSION  H(2 , 2 , 5)  pyPIX 

AREA  =0.0  HTREA 

AB  =  0.0  HTREA 

BB  =  0.0  HYREA 

IF  (L.LT.2)  GO  TO  20  HYFIX 

DO  15  I  =  1,L  HYFIX 

AR  =  H( 1 . 1 , I) «H(2 . 2 . I)  -  H( 1 , 2 , I) *H(2 ,1,1)  HYFIX 

IF  (AR.EQ.0.0)  GO  TO  5  HYFIX 

AB  =  AB  +  ABMHd.l.I)  ♦  H(1.2,I))  HYFIX 

BB  =  BB  ♦  AB» (H(2 , 1 , I)  ♦  H(2,2,I))  HYFIX 

AREA  =  AREA  ♦  AR  HYREA 

5  AR  =  H( 1 , 2 , I) »H(2 , 1 . 1*1)  -  H ( 1 . 1 , 1+ 1 ) *H(2 ,2 , I )  HYFIX 

IF  (AR.EQ.0.0)  GO  TO  15  HYFIX 

AB  =  AB  ♦  AR* (H ( 1 , 1 , 1+ 1 )  ♦  H(1,2.I)>  HYFIX 

BB  =  BB  ♦  AR* (H(2 , 1,1*1)  ♦  H(2.2,I))  HYFIX 

AREA  =  AREA  ♦  AR  HYREA 

15  CONTINUE  HYFIX 

IF  (AREA. LE. 0.0)  GO  TO  20  HYFIX 

AREA  =  3.0* AREA  HYREA 

AB  =  AB/AREA  HYREA 

BB  =  BB/AREA  HYREA 

AREA  =  AREA/6.0  HYREA 

20  RETURN  hythta 
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SUBROUTINE  HYSOL(A,N,ND) 

C 

IMPLICIT  REAL* 8 (A-H ,0-Z) 

DIMENSION  A(ND ,6) 

C  ASSUMES  PITOT  ON  DIAGONAL  ,  BYPASS  O’S 
Ml  =  N  ♦  1 
DO  20  L  =  1,N 
IF (A(L ,L) . EQ.O.OlGO  TO  20 
LI  =  L  ♦  1 
DO  10  J  =  LI .Ml 
10  A(L.J)  =  A(L, J) /A(L,L) 

IF (L.EQ.N)GO  TO  20 
DO  21  I  =  Ll.N 
IF(A(I.L) .EQ. 0.0)00  TO  21 
DO  15  J  =  Ll.Nl 

15  A(I.J)  =  A(I.J)  -  A(I ,L) *A(L, J) 

21  CONTINUE 
20  CONTINUE 

IF1N.EQ. 1)00  TO  30 
C  BACKUP 

DO  25  L  =  2.N 
I  =  N1  -  L 
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Ll  =  I  ♦  1 

HYSOL 
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DO  25  J  =  Ll.N 

HYSOL 

25  A(I.N1)  =  A(I.Nl)  -  A ( I , J) *A(J ,N1) 

HYSOL 

a 

30  RETURN 

HYSOL 

■ 

END 

HYSOL 

SUBROUTINE  HYVAL ( A , U , R , BD , L)  HYVAL 

C  RE?  I?  12/ I 1/87HYFIX 

IMPLICIT  REAL*8 (A-H ,0-Z)  HYVAL 

C  GIVEN  A, U,R:  COMPUTE  A  Z  =  A*U  ♦  R  HYVAL 

DIMENSION  BD(24) ,U(3) ,B(3) ,RM(2)  HYFIX 

ONE  =  1.0  HYFIX 

POW  =  -BD { 1 )  -  2.0  HYVAL 

C  ARE  THESE  THE  CORRECT  TESTS??  HYFIX 

TEST  =  -BD(1) *0.000001  HYFIX 

TESD  =  0.000001  HYFIX 

CALL  HYVBX(U,R,BD(2) ,M,RM)  HYVAL 

A  =  0.0  HYFIX 

IF  (M.LT.L)  GO  TO  50  HYFIX 

C  THIS  SHOULD  NEVER  HAPPEN  -  IMPLIES  R  IS  OUTSIDE  BOX  HYFIX 

A  =  RM(L)  HYVAL 

IF  (DABS ( A) .LT. TESD)  GO  TO  50  HYFIX 

DEL  =  A/5.0  HYFIX 

NSTEP  =  0  HYFIX 

C  ITERATION  LOOP  HYFIX 

10  DEL  =  DEL/4.0  HYFIX 

NSTEP  =  NSTEP  ♦  1  HYFIX 

IF  (NSTEP.LT. 100)  GO  TO  12  HYFIX 

WRITE (6 , 11)  M.A.DEL.Fl ,F2,L,RM(1) ,RM(2) , U,R,BD  HYFIX 

11  FORMAT ( *  HYV  ’ , 14 ,4F1 1 .6, 13 ,2F1 1 .8/4X.3F1 1 .8 .4X.3F11 .0/  HYFIX 

»  4(2X,7F10.4/) )  HYFIX 

STOP  102  HYFIX 

12  F2  =  HYVFN ( A , U , R , BD , POW)  HYFIX 

IF  (DABS (F2) .LT. TEST)  GO  TO  50  HYFIX 

IF  (F2)  20.50,30  HYFIX 

15  F2  =  HYVFN (A , U , R , BD , POW)  HYFIX 

NSTEP  =  NSTEP  *1  HYFIX 

IF  (NSTEP.LT. 100)  GO  TO  17  HYFIX 

WRITE (6 , 1 1 )  M, A, DEL, FI ,F2,L,RM(1) ,BM(2) .U.R.BD  HYFIX 

STOP  103  HYFIX 

17  IF  (DABS (F2) .LT. TEST)  GO  TO  50  HYFIX 

IF  (F2)  20,50,35  HYFIX 

20  IF  (DSIGN(ONE.A) . EQ . DSIGN (ONE , A+DEL) )  GO  TO  22  HYFIX 

A  =  A/2.0  HYFIX 

DL  =  -A  HYFIX 

GO  TO  23  HYFIX 

22  DL  =  DEL  HYFIX 

A  =  A  +  DEL  HYFIX 

23  FI  =  F2  HYFIX 

GO  TO  15  HYFIX 

25  F2  =  HYVFN(A, U.R.BD, POW)  HYFIX 

NSTEP  =  NSTEP  +1  HYFIX 

IF  (NSTEP.LT. 100)  GO  TO  27  HYFIX 

WRITE(6 , 11)  M,A,DEL,F1 ,F2,L,RM(1) ,RM(2) , U.R.BD  HYFIX 

STOP  104  HYFIX 

27  IF  (DABS (F2) .LT. TEST)  GO  TO  50  HYFIX 
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IF  (F2)  35,50,30 

30  IF  (DSIGN(ONE,A) . EQ.DSIGN(ONE,A-DEL) )  GO  TO  32 
A  =  A/2.0 
DL  =  -A 
GO  TO  33 

32  DL  =  -DEL 

A  =  A  -  DEL 

33  FI  =  F2 
GO  TO  25 

35  IF  (F1.EQ.F2)  GO  TO  50 
A  =  A  +  F2*DL/(F1  -  F2) 

IF  (DABS (DEL) .GT.TESD)  GO  TO  10 

50  RETURN 
END 
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SUBROUTINE  H YVBX ( Q , S , B , M , RM)  HYVBX 

C  REV  IV  02/07/87HYVBX 

IMPLICIT  REAL«8(A-H,0-Z)  HYVBX 

DIMENSION  Q (3) ,S(3) ,B(3) ,RM(2)  HYVBX 

C  FINDS  LIMITS  OF  BOX  IN  DIRECTION  Q,  Z  =  R«Q  +  S  HYVBX 

LOGICAL  VAL  HYVBX 

M  =  0  HYVBX 

C  =  -1.0  HYVBX 

DO  30  I  =  1,3  HYVBX 

IF (Q ( I ) .EQ.O.OIGO  TO  30  HYVBX 

DO  25  K  =  1,2  HYVBX 

VAL  =  .TRUE.  HYVBX 

D  =  C«B(I)  -  S ( I )  HYVBX 

DO  10  J  =  1,3  HYVBX 

IF (J.EQ. I) GO  TO  10  HYVBX 

IF (DABS (D»Q ( J)  +  S(J)«Q(I)) .GT.DABS (B (J) *Q (I) ) ) VAL  =  .FALSE.  HYVBX 

C  IF (DABS (R*Q ( J)  +  S(J) ) .GT.B(J) ) VAL  =  .FALSE.  HYVBX 

10  CONTINUE  HYVBX 

IF (.NOT. VAL) GO  TO  25  HYVBX 

R  =  D/Q(I)  HYVBX 

IF (M. EQ . 0) GO  TO  20  HYVBX 

DO  15  L  =  l.M  HYVBX 

IF (R.EQ.RM(L) )  GO  TO  25  HYVBX 

15  CONTINUE  HYVBX 

20  M  =  M  +  1  HYVBX 

RM(M)  =  R  HYVBX 

25  C  =  -C  HYVBX 

30  CONTINUE  HYVBX 

IF(M.EQ.O)GO  TO  35  HYVBX 

I F ( RM ( 1 ) .LT.RM(2))GO  TO  35  HYVBX 

R  -  RM(1)  HYVBX 

RM ( 1 )  =  RM(2)  HYVBX 

RM(2)  =  R  HYVBX 

35  RETURN  HYVBX 

END  HYVBX 


DOUBLE  PRECISION  FUNCTION  HYVFN(A,U,R,B,P)  HYVFN 

REV  IF  12/11/87HTVFN 

IMPLICIT  REAL*8 (A-H.O-Z)  HYVFN 

DIMENSION  U(3) ,R(3) ,B(24)  HYVFN 

F  =  -1.0  HYVFN 

DO  10  I  =  1,3  HYVFN 

Z  =  A»U(I)  ♦  B(I)  HYVFN 

C  =  B(I+16)  HYVFN 

IF  (P.GT.0.0)  C  =  HYFCN(C,Z,B(I+1) ,P)  HYVFN 

F  =  F  ♦  C»Z**2  HYVFN 

HYVFN  =  F  HYVFN 

RETURN  HYVFN 

END  HYVFN 


SUBROUTINE  IMPLS2 (MODE , J ,H)  IMPLS2 

REV  IV  07/24/86SLIP 

CALLED  BY  SUBROUTINE  UPDATE  WHEN  JOINT  J  LOCKS  TO  APPLY  IMPULSE  I  MPLS 2 
TO  SET  P. (D(M) ' W(M)  -  D(N)’W(N))  =  0  IMPLS2 

IMPLS2 

ARGUMENTS:  IMPLS2 

MODE  -  0:  FULL  LOCK  P  =  I  IMPLS2 

1:  AXIS  (H)  FREE  P  =  I-HH’  IMPLS2 

-I:  AXIS  (H)  LOCKED  P  =  HH’  IMPLS2 

IMPLS2 

J  -  JOINT  IDENTIFICATION  NUMBER  IMPLS2 

IMPLS2 

H  -  AXIS  VECTOR  IMPLS2 

IMPLS2 

IMPLS2 

IMPLICIT  REAL*8 (A-H.O-Z)  IMPLS2 

COMMON/CONTRL/  TIME , NSEG , NJNT , NPL . NBLT , NBAG , NVEH , NGRND ,  IMPLS2 

*  NS , NQ , NSD , NFLX , NHRNSS , NWI NDF , NJMTF , NPRT ( 36 ) , NPG  PAGE 

COMMON/ SGMNTS/  D(3,3.30) ,WMEG(3,30) ,WMEGD(3,30) ,U1(3,30) , U2 (3 ,30) , IMPLS2 

»  SEGLP (3 , 30) , SEGLV(3 ,30) ,SEGLA(3,30) ,NSYM(30)  IMPLS2 

COMMON/ DESCRP/  PHI (3,30) ,W(30) ,RW(30) ,SR(4,60) ,HA(3,60) ,HB(3.60) ,  SLIP 

»  RPHI(3,30) ,HT(3,3,60) , SPRING(5 ,90) ,VISC(7,90) ,  IMPLS2 

*  JNT(30) , IPIM (30) ,ISING(30) ,IGL0B(30) ,J0INTF(30)  IMPLS2 

COMMON/ CMATRX/  VK3.30)  ,V2(3.30)  ,V3(3.12)  ,B12(3,3,60)  ,A22(3,3,80)  , IMPLS2 

«  F(3,30) ,TQ(3,30) ,WJ(30) ,A11(3,3.30)  SLIP 

COMMON/ CSTRNT/  A13(3,3,24) ,A23(3,3,24) ,B3I(3,3,24) ,B32(3,3,24) ,  IMPLS2 

»  HHT(3,3, 12) ,RK1 (3,12) ,BK2(3,12) ,QQ(3,I2) ,TQQ(3 . 12) , IMPLS2 

»  RQQ(3, 12) ,HQQ(3, 12) ,SQQ(12) ,CFQQ(12) ,  IMPLS2 

»  KQ1 (12) ,KQ2(12) ,KQTYPE(12)  IMPLS2 

COMMON/ FLXBLE/  HF(4 , 12 ,8) ,B42 (3 ,3 , 24) , V4 (3 ,8) ,NFLEX(3 ,8)  IMPLS2 

COMMON/TEMPVS/  SM(3) ,SN(3) ,TM(3,3) ,TN(3,3) ,T(3,4) ,TT(3,4)  IMPLS2 

DIMENSION  TWA(3,3,30) ,TLA(3,3,30) ,H(3)  IMPLS2 

CALL  ELTIMEd  ,28)  IMPLS2 

M  =  JNT(J)  IMPLS2 

N  =  J+l  IMPLS2 

DO  20  L= 1 ,3  IMPLS2 

DO  12  K=l, NGRND  IMPLS2 

DO  12  1*1,3  IMPLS2 

U1(I,K)  =  0.0  IMPLS2 

12  U2(I,K)  =  0.0  IMPLS2 

DO  13  K=1 ,NJNT  IMPLS2 

DO  13  1=1,3  IMPLS2 

VI (I, K)  =  0.0  I MPLS 2 

13  V2(I ,K)  =  0.0  IMPLS2 

IF  (NQ.LE.O)  GO  TO  15  IMPLS2 

DO  14  K= 1 , MQ  IMPLS2 

DO  14  1=1,3  IMPLS2 

14  V3 ( I ,K)  =  0.0  I MPLS 2 

15  IF  (NFLX.EQ.O)  GO  TO  18  IMPLS2 

DO  19  K= 1 , NFLX  IMPLS2 
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DO  19  1=1,3 

19  V4 (I ,K)  =  0.0 
18  DO  16  1=1,3 

U2(I,M)  =  RPHI ( I ,  M)  »D  ( I ,  L ,  M) 

16  U2 { I ,N)  =-RPHI(I,N)»D(I,L,N) 

CALL  DAUX(L) 

DO  17  K= 1 , NGRND 
DO  17  1=1,3 

TLA(I,L,K)  =  SEGLA(I ,K) 

17  TWA (I ,L,K)  =  WMEGD(I.K) 

20  CONTINUE 

CALL  DOT33(D(l , 1 ,M) ,TWA(1,1,M) ,TM) 

CALL  DOT33 (D (1,1, N) ,TWA(1,1,N) ,TN) 

CALL  D0T3 1  (D  ( 1 , 1 ,  M)  ,  WMEG  ( 1 ,  M)  ,  SM) 

CALL  D0T3 1 ( D ( 1 , 1 , N) , WMEG ( 1 ,  N) ,  SN) 

DO  22  1=1,3 
DO  21  K=1 ,3 

T (I , K)  =  TM(I,K)  -  TN(I,K) 

21  TT(I.K)  =  T(I,K) 

T(1 .4)  =  SN ( I )  -  SM(I) 

22  TT ( I , 4)  =  H ( I ) 

IF  (MODE.GE.O)  CALL  DSMS0L(T,3,3) 

IF  (MODE.GT.O)  CALL  DSMS0L(TT,3,3) 

IF  (MODE)  24,29,25 

24  ST  =  0.0 

STT  =  XDY(H.T.H) 

GO  TO  26 

25  ST  =  1.0 

STT  =  - (H( 1) *TT (1,4)  +  H(2) «TT(2 ,4)  ♦  H(3) *TT(3,4) ) 

26  STT  =  (H(l) »  T ( 1 , 4)  +  H(2)»  T (2 , 4)  +  H(3)«  T(3,4))/STT 
DO  27  1=1,3 

27  T(I ,4)  =  ST*T (1,4)  ♦  STT*TT(I,4) 

29  DO  30  K=l, NGRND 
DO  30  1=1,3 

DO  30  L= 1 , 3 

SEGLV(I.K)  =  SEGLV(I.K)  ♦  T(L,4) »TLA(I ,L,X) 

30  WMEG  (I.K)  =  (WffiG  (I.K)  ♦  T(L,4) *TWA(I ,L,K) 

IF  (NPRT (3) . NE. 0)  CALL  PRINT (6HIMPLS2) 

CALL  ELTIME (2,28) 

RETURN 

END 
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SUBROUTINE  IMPULS (1 1 , 12 , 13)  IMPULS 

REV  IV  07/24/86SLIP 

ARGUMENTS:  11=1-  IMPULS  FOR  PLELP.  IMPULS 

3  -  IMPULS  FOR  SEGSEG.  IMPULS 

4  -  IMPULS  FOR  VISPR  OR  EJOINT  IMPULS 

12  =  INDEX  OF  CONTACTING  SEGMENT  OR  JOINT  AXIS  IMPULS 

13  =  INDEX  OF  PLANE,  SEGMENT  OR  JOINT  AXIS  IMPULS 

IMPULS 

IMPULS 

IMPLICIT  REAL* 8  (A-H.O-Z)  IMPULS 

COMMON/CONTRL/  TIME, NSEG , NJNT , NPL , NBLT , NBAG , NVEH , NGRND ,  IMPULS 

*  NS , NQ , NSD , NFLX , NHRNSS . NWINDF , NJNTF , NPRT (36) , NPG  PAGE 

COMMON/ SGMNTS/  D(3,3,30) ,WMEG(3,30) ,WMEGD(3,30) ,U1(3,30) ,U2(3,30) .IMPULS 

*  SEGLP(3,30) ,SEGLV(3,30) ,SEGLA(3,30) ,NSYM(30)  IMPULS 

COMMON/DESCRP/  PHI (3,30) ,W(30) ,RW(30) , SR (4, 60) ,HA(3,60) ,HB(3,60) ,  SLIP 

*  RPHI (3,30) ,HT(3 , 3 ,60) , SPRING (5 , 90) , VISC (7 ,90) ,  IMPULS 

*  JNT(30) ,IPIN(30) ,ISING(30) ,IGL0B(30) ,J0INTF(30)  IMPULS 

COMMON/CMATRX/  VI (3,30) ,V2(3,30) ,V3(3,12) ,B12(3,3,60) ,A22(3,3,60) .IMPULS 

*  F  (3 , 30)  ,TQ  (3 , 30)  ,  WJ  (30)  ,  A1 1  (3 , 3 , 30)  SLIP 

COMMON/ JBARTZ/  MNPL(  30) ,MNBLT(  8) ,MNSEG(  30) ,MNBAG(  6),  IMPULS 

»  MPL(3,5,30) , MBLT(3,5,8) , MSEG(3 , 5 ,30) , MBAG(3, 10,6) ,  IMPULS 

*  NTPL(  5,30) ,NTBLT(  5,8),NTSEG(  5,30)  IMPULS 

COMMON/CSTRNT/  A13(3,3,24) ,A23(3,3,24) ,B31 (3,3,24) ,B32(3,3,24) ,  IMPULS 

*  HHT (3 , 3 , 12) , RK 1 ( 3 , 1 2 ) ,RK2(3,12) ,QQ(3,12) , TOO (3, 12) .IMPULS 

*  RQQ (3 ,12) ,HQQ (3 ,12) ,SQQ (12) ,CFQQ ( 12) ,  IMPULS 

«  KQ1(12) ,KQ2(12) ,KQTYPE(12)  IMPULS 

COMMON/FLXBLE/  HF (4 , 12 , 8) ,B42 (3 ,3 , 24) , V4 (3 ,8) ,NFLEX(3 , 8)  IMPULS 

COMMON/TEMPVI/  CREST ,TTI (3) ,R1 I (3) ,R2I (3) , JSTOP (4 , 2 ,30)  IMPULS 

COMMON/TABLES/MXNTI .MXNTB.MXTBl ,MXTB2,NTI (50) ,NTAB(1250) , TAB (4500) DIMENB 
DIMENSION  TEMP (3) ,  DWR1 (3) ,  DWR2 (3) , DWB3 (3) ,  DWR4 (3) , VREL (3) , DV(3)  IMPULS 
IF  (TIME. EQ. 0.0)  GO  TO  99  IMPULS 

IMPULS 

SPECIAL  SETUP  FOR  CALL  TO  SUBROUTINE  DAUX  IMPULS 

REPLACE  SETUP  WITH  U1 ,U2 ,V1 , V2 , V3  =  0.  IMPULS 

ASSUME  OTHER  ARRAYS  FROM  PREVIOUS  CALL  TO  DAUX.  IMPULS 

IMPULS 

CALL  ELTIME ( 1,27)  IMPULS 

CALL  OUTPUT (0)  IMPULS 

KQTEST  =  0  IMPULS 

NT  =  0  IMPULS 

IF  (Il.EQ.l)  NT  =  NTPL  (12,13)  IMPULS 

IF  (I1.EQ.3)  NT  =  NTSEG(I2, 13)  IMPULS 

IF  (NT.EQ.O)  GO  TO  29  IMPULS 

KQ  =  -NTAB (NT+ 1 )  IMPULS 

IF  (KQ.LE.O)  GO  TO  29  IMPUL* 

KQTYPE(KQ)  =  IABS (KQTYPE (KQ) )  IMPULS 

CALL  DAUX ( 0 )  IMPULS 

29  IF  (NQ.LE.O)  GO  TO  31  IMPULS 

DO  30  J  = 1 , NQ  IMPULS 

DO  30  1=1,3  IMPULS 


30  V3 (I , J)  =0.0  IMPULS 

31  DO  32  J  = 1 , NGRND  IMPULS 

DO  32  1=1,3  IMPULS 

Ul(I.J)  =  0.0  IMPULS 

32  U2 (I , J)  =  0.0  IMPULS 

IF  (NJNT.LE.O)  GO  TO  21  IMPULS 

DO  33  J= 1 ,NJNT  IMPULS 

DO  33  1=1,3  IMPULS 

VI (I, J)  =  0.0  IMPULS 

33  V2 (I , J)  =  0.0  IMPULS 

21  IF  (NFLX.EQ.O)  GO  TO  23  IMPULS 

DO  22  J=1,NFLX  IMPULS 

DO  22  1=1,3  IMPULS 

22  V4 (I , J)  =  0.0  IMPULS 

C  IMPULS 

C  REPLACE  CALLS  TO  CONTACT  AND  VISPR  WITH  SINGLE  CALL  IMPULS 

C  AT  FIRST  CONTACT  IF  NOT  CONSTRAINT.  IMPULS 

C  IMPULS 

23  IF  (Il.NE.l)  GO  TO  34  IMPULS 

NT  =  NTPL (12,13)  IMPULS 

Ml  =  MPL(1, 12,13)  IMPULS 

M2  =  MPL(2 , 12 , 13)  IMPULS 

M3  =  MPL (3 ,12,13)  IMPULS 

CALL  PLELP(M2,M3,M1 ,13, NT)  IMPULS 

IF  (NTAB(NT+1) .LT.O)  GO  TO  37  IMPULS 

K1  =  M2  IMPULS 

K2  =  Ml  IMPULS 

GO  TO  39  IMPULS 

34  IF  (I1.NE.3)  GO  TO  35  IMPULS 

NT  =  NTSEGCI2 ,13)  IMPULS 

Ml  =  MSEG(1 , 12 , 13)  IMPULS 

M2  =  MSEG(2 ,12 ,13)  IMPULS 

M3  =  MSEG(3 , 12 ,13)  IMPULS 

CALL  SEGSEG(I3 , Ml ,M2 ,M3 , NT)  IMPULS 

IF  (NTAB(NT+1) .LT.O)  GO  TO  37  IMPULS 

K1  =  13  IMPULS 

K2  =  M2  IMPULS 

GO  TO  39  IMPULS 

35  IF  (I1.NE.4)  WRITE  (6,36)  11,12,13  IMPULS 

36  FORMAT ( ’ 0  IMPROPER  ARGUMENTS  TO  SUBROUTINE  IMPULS’/  IMPULS 

»  ’  ARGUMENTS  =  ’ ,  316  /  IMPULS 

*  ’  PROGRAM  TERMINATED’  )  IMPULS 

IF  (I1.NE.4)  STOP  33  IMPULS 

C  IMPULS 

C  RECALL  VISPR  FOR  JOINT  STOP.  IMPULS 

C  IMPULS 

IF  ( I ABS ( IPIN ( 13) ) .NE.4)  GO  TO  25  IMPULS 

CALL  EJOINT (12 , 13)  IMPULS 

GO  TO  26  IMPULS 

25  CALL  VISPR<I2,I3)  IMPULS 
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26  K1  -  IABS ( JNT ( 13) )  IMPULS 

K2  =  13+1  IMPULS 

GO  TO  39  IMPULS 

IMPULS 

SET  UP  SPECIAL  U1.U2  FOR  FIRST  CONTACT  OF  CONSTRAINT.  IMPULS 

IMPULS 

37  KQ  =  -NTAB (NT+ I )  IMPULS 

KQTEST  =  1  IMPULS 

KQTYPE(KQ)  =  -IABS (KQTYPE (KQ) )  IMPULS 

K1  =  KQKKQ)  IMPULS 

K2  =  KQ2 (KQ)  IMPULS 

IF  (Kl.GT.NSEG)  GO  TO  38  IMPULS 

CALL  MAT31 (A13(l , 1 , 2»KQ-1) ,QQ(1 ,KQ) ,U1 (1 ,K1) )  IMPULS 

CALL  MAT31 (A23 ( 1 , 1 , 2*KQ-1) ,QQ(1 ,KQ) ,U2(I ,K1) )  IMPULS 

38  IF  (K2.GT.NSEG)  GO  TO  39  IMPULS 

CALL  MAT31(A13( 1,1, 2»KQ  ) ,QQ(1 ,KQ) ,UI (1 ,K2) )  IMPULS 

CALL  MAT3KA23  (1.1, 2»KQ  )  ,QQ(1  .KQ)  ,U2(1  ,K2) )  IMPULS 

IMPULS 

FINAL  SETUP  OF  U1  AND  U2  IMPULS 

IMPULS 

39  DO  40  J  = 1 , NGRND  IMPULS 

DO  40  1=1,3  IMPULS 

Ul(I.J)  =  U1 (I , J) »RW(J)  IMPULS 

40  U2 (I , J)  =  U2 (I , J ) *RPHI ( I , J)  IMPULS 

CALL  DAUX(Il)  IMPULS 

IF  (KQTEST. EQ. 1)  KQTYPE (KQ)  =  IABS (KQTYPE (KQ) )  IMPULS 

IF  (NPRT(IO) .NE.O)  CALL  PRINT (6HPRE IMP)  IMPULS 

IF  (I1.GT.3)  GO  TO  51  IMPULS 

IF  (NPRT(IO) .NE.O)  WRITE  (6,42)  RII.R2I  IMPULS 

42  FORMAT  ( ’ 0 ’ / (6G20 . 8) )  IMPULS 

CALL  CROSS (WMEG  ( 1 , K 1 ) , R 1 I ( 1 ) , TEMP)  IMPULS 

CALL  D0T31 (D(l , 1 ,K1) .TEMP.DWR1 (1) )  IMPULS 

CALL  CROSS (WMEG  (1 ,K2) ,R2I (1) .TEMP)  IMPULS 

CALL  D0T3 1 ( D ( 1 , 1 , K2 ) , TEMP , DWR2 ( 1 ) )  IMPULS 

CALL  CROSS (WMEGD ( 1 , K 1 ) ,R1I(1) ,TEMP)  IMPULS 

CALL  D0T31 (D(l , 1 ,K1) , TEMP , DWR3 ( 1 ) )  IMPULS 

CALL  CROSS (WMEGD ( 1 , K2) , R2I ( 1 ) , TEMP)  IMPULS 

CALL  D0T31 (D ( 1 , 1 , K2'  , TEMP ,DWR4 ( 1) )  IMPULS 

TVREL  =0.0  IMPULS 

TDV  =0.0  IMPULS 

DO  50  1=1,3  IMPULS 

VREL(I)  =  SEGLV(I , K 1 ) +DWR1 (I)  -  SEGLV ( I , K2 ) -DWR2 ( I )  IMPULS 

DV  (I)  =  SEGLA(I , K 1 ) +DWR3 (I)  -  SEGLA (I , K2) -DWR4 ( I )  IMPULS 

TVREL  =  TVREL  ♦  TTI(I)»VREL(I)  IMPULS 

50  TDV  =  TDV  +  TTHIMDV  (I)  IMPULS 

GO  TO  53  IMPULS 

51  CALL  D0T3 1 ( D (1 , 1 , K 1 ) , WMEG  ( 1 ,K1)  ,DWR1 ( 1) )  IMPULS 

CALL  D0T31(D( 1,1, K2) .WMEG  ( 1 ,K2) , DWR2 ( 1 ) )  IMPULS 

CALL  D0T3 1 ( D ( 1 , 1 , K 1 ) , WMEGD (1 , K 1 ) , D WR3 (1 ) )  IMPULS 

CALL  D0T31 (D ( 1 , 1 ,K2) , WMEGD (1 ,K2) , DWR4 (1) )  IMPULS 


TVREL  =0.0  IMPULS 

TDV  =0.0  IMPULS 

DO  52  1=1,3  IMPULS 

VREL(I)  =  DWRl(I)  -  DWR2(I)  IMPULS 

DV  (I)  =  DWR3 ( I )  -  DWR4 ( I )  IMPULS 

TVREL  =  TVREL  +  TTI (I) *VREL(I)  IMPULS 

52  TDV  =  TDV  +  TTI(I)*DV  (I)  IMPULS 

53  ALPHA  =0.0  IMPULS 

IMPULS 

MOTE:  CREST  IS  SUPPLIED  AS  (I+E)/2  WHERE  E  IS  THE  CLASSICAL  IMPULS 

COEFFICIENT  OF  RESTITUTION  BUT  WITH  A  RANGE  OF  -I  TO  +1.  IMPULS 

CREST  HAS  A  RANGE  OF  0  TO  *1  WHERE  0  (E=-l)  REPRESENTS  NO  IMPULSE. IMPULS 

IMPULS 

IF  (TDV. NE. 0.0)  ALPHA  =  -2 . 0*CREST*TVREL/TDV  IMPULS 

IF  (NPRT(IO) .NE.O)  WRITE  (6,42)  DWR1 ,DWR2 ,DWR3 ,DWR4 ,  IMPULS 

*  TTI.VREL.DV,  IMPULS 

*  TVREL , TDV , CREST , ALPHA  I MPULS 

DO  60  J  = 1 , NGRND  IMPULS 

DO  60  1=1,3  IMPULS 

SEGLV(I.J)  =  SEGLV(I.J)  +  ALPHA*SEGLA(I ,J)  IMPULS 

60  WMEG  ( I , J)  =  WMEG  ( I . J)  ♦  ALPHA* WMEGD ( I , J )  IMPULS 

IF  (NPRT(IO) .NE.O)  CALL  OUTPUT ( 1 )  IMPULS 

IF  (NPRT(  3) .NE.O)  CALL  PRINT (6HIMPULS)  IMPULS 

CALL  ELTIME(2 ,27)  IMPULS 

99  RETURN  IMPULS 

END  IMPULS 
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SUBROUTINE  INITAL  INITAL 

C  REV  IV  07/24/86SLIP 

C  PERFORMS  CARD  INPUT  AND  COMPUTATIONS  FOR  INITIAL  INITAL 

POSITIONING  OF  THE  CRASH  VICTIM'S  BODY  SEGMENTS.  INITAL 

INITAL 

IMPLICIT  REAL»8 (A-H ,0-Z)  INITAL 

COMMON/CONTRL/  T I ME , NSEG , N JNT , NPL , NBLT , NBAG , NVEH , NGRND ,  INITAL 

*  NS ,NQ,NSD .NFLX.NHRNSS .NWINDF ,NJNTF ,NPRT(36) ,NPG  PAGE 

COMMON/SGMNTS/  D(3,3,30) ,WMEG(3,30) ,WMEGD(3,30) , U1 (3,30) ,U2(3,30) .INITAL 

*  SEGLP(3,30)  ,SEGLV(3,30) ,SEGLA(3,30) ,NSYM(30)  INITAL 

COMMON/ DESCRP/  PHI (3,30) ,W(30) ,RW(30) ,SR(4.60) ,HA(3,60) ,HB(3,60) ,  SLIP 

»  RPHI(3,30) ,HT(3,3,60) ,SPRING(5 ,90) ,VISC(7,90) ,  INITAL 

*  JNT(30) ,IPIN(30) ,ISING(30) ,IGL0B(30) ,J0INTF(30)  INITAL 

COMMON/ VPOSTN/  ZPLT (3) . SPLT (3) , AXV (3 , 6) , VATAB (6 . 50 1 , 6) .  VEHICL 

»  VT0(6) ,VDT(6) ,TIMEV(6) ,0MEGV(6) ,NVTAB(6) ,INDXV(6)  INITAL 

COMMON/TITLES/  DATE(3) ,C0MENT(40) ,VPSTTL(20) ,BDYTTL(5) ,  INITAL 

*  BLTTTL(5,8) ,PLTTL(5,30) ,BAGTTL(5,6) ,SEG(30) ,  INITAL 

»  JOINT(30) ,CGS(30) ,JS(30)  INITAL 

COMMON/CEULER/  IEULER(30) ,HIR(3 , 3 , 90) , ANG(3 , 30) , ANGD (3 , 30) ,  JDRIFT 

*  FE(3,30) ,TQE(3,30) ,C0NST(5,30)  JDRIFT 

REAL  DATE . COMENT , VPSTTL . BDYTTL , BLTTTL , PLTTL , BAGTTL , SEG . JOINT  INITAL 

LOGICAL# 1  CGS.JS  INITAL 

COMMON/CNSNTS/  PI , RADI AN ,G .THIRD .EPS (24) ,  INITAL 

»  UN I TL , UNI TM , UNI TT , GRAVT Y ( 3 ) . TWOP I  TWOPI 

COMMON/ TEMP VS/  TMP ( 140) . WMGDEG(3 .30) ,T (3) .S (3) , A(3 . 2) ,Z(3 . 3)  SLIP 

NOTE  :  CHAIN  ALSO  USES  TEMPVS.  INITAL 

DIMENSION  YPR(3 ,30)  ,  IYPR(4,30)  INITAL 

INITAL 

INPUT  CARD  G.l.A  (PLOT  COORDINATES  OF  VEHICLE  REFERENCE  ORIGIN)  INITAL 

INITAL 

READ (5 , 22)  ZPLT . II , J1 , 12 . J2 , 13  INITAL 

22  FORMAT(3F10. 0,514)  INITAL 

S(l)  =  10.0  INITAL 

S ( 2 )  =  6.0  INITAL 

S (3)  =  1.0  INITAL 

INITAL 

IF  J1*0,  INPUT  CARD  G.l.B  (PLOT  SCALING  INPUT)  INITAL 

INITAL 

IF  (Jl.NE.O)  READ  (5,22)  S  INITAL 

SPLT ( 1 )  =  1 . 0/S (3)  INITAL 

SPLT (2)  =  1 . 0/S (3)  INITAL 

SPLT(3)  =  — (S(l)/S(2) )/S (3)  INITAL 

WRITE  (6,23)  NPG,ZPLT,I1 ,J1 ,12, J2, 13, S  PAGE 

NPG=NPG+ 1  PAGE 

23  FORMAT ( ’ 1  SUBROUTINE  INITAL  INPUT' ,98X, ’PAGE’ , 15/1 20X, ’CARD  G.l’/  PAGE 

»  ’  ZPLT (X)  ZPLT(Y)  ZPLT (Z)  II  J1  12  J2  13’, INITAL 

»  ’  SPLT ( 1 )  SPLT(2)  SPLT (3) ’/3F10.0,5I6,3F10.2)  INITAL 

C  INITAL 

C  INPUT  CARDS  G.2.A  -  G.2.N  INITAL 

C  INITAL 
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C  INITIAL  LINEAR  POSITION  (IN)  AND  (IF  13=1)  VELOCITY  (IN/SEC)  INITAL 

C  OF  EACH  BASE  BODY  SEGMENT.  IF  13=0,  VELOCITY  WILL  BE  SET  TO  INITAL 

C  INITIAL  VELOCITY  OF  VEHICLE.  INPUTS  IN  INERTIAL  REFERENCE.  INITAL 

C  INITAL 

DO  37  J= 1 ,NSEG  INITAL 

IF ( J . GT . 1 . AND . IABS ( JNT ( J- 1 ) ) .GT . 0)  GO  TO  37  INITAL 

READ (5 , 24)  (SEGLP (I , J) , 1= 1 ,3) , (SEGLV ( I , J) , 1= 1 ,3)  INITAL 

24  FORMAT  (6F10.0  ,  413)  INITAL 

I F ( 1 3 . GT . 0 )  GO  TO  37  INITAL 

DO  36  1=1,3  INITAL 

36  SEGLV(I.J)  =  SEGLV(I.NVEH)  INITAL 

37  CONTINUE  INITAL 

C  INITAL 

C  INPUT  CARDS  G.3.A  -  G.3.N  INITAL 

C  INITAL 

C  FOR  EACH  BODY  SEGMENT  SUPPLY  YAW,  PITCH  AND  ROLL  (DEGREES)  INITAL 

C  AND  (IF  13=1)  THE  ANGULAR  VELOCITY  IN  LOCAL  REFERENCE  (DEG/SEC).  INITAL 
C  IF  13=0,  THE  ANGULAR  VELOCITY  (BLANK  ON  INPUT  CARDS)  WILL  BE  SET  INITAL 

C  EQUAL  TO  THE  INITIAL  ANGULAR  VELOCITY  OF  THE  VEHICLE.  INITAL 

C  INITAL 

FIRST  =0.0  INITAL 

DO  40  J=1 ,NSEG  INITAL 

READ  (5,24)  (YPR(I.J) ,1=1,3) , (WMGDEG(I.J) ,1=1,3) , (IYPR(I.J) , 1= 1 . 4) INITAL 
ID1  =  IYPR(l.J)  INITAL 

DO  38  1=1,3  INITAL 

IF  (ID1.EQ.0)  IYPR(I.J)  =  I  INITAL 

38  WMEG(I,J)  =  WMGDEG(I , J) * RADI AN  INITAL 

IF  (ID1.GE.0)  GO  TO  60  INITAL 

C  INITAL 

C  READ  CARD  G.3.J2  FOR  SEGMENT  NO.  J  WHEN  IYPR(l.J)  IS  NEGATIVE.  INITAL 

C  INITAL 

READ  (5,24)  A, II , IK, JJ , JK  INITAL 

IJ  *  II  INITAL 

LK  =  IK  INITAL 

DO  54  K= 1 , 2  INITAL 

IF  (IJ.GT.O)  GO  TO  52  INITAL 

DO  51  1=1,3  INITAL 

51  Z ( I , LK)  =  A ( I , K)  INITAL 

GO  TO  53  INITAL 

52  DAI  =  A ( 1 , K ) » RADIAN  INITAL 

DA2  =  A(2,K) »RADIAN  INITAL 

SA1  =  DSIN(DAl)  INITAL 

SA2  =  DSIN (DA2)  INITAL 

CA1  =  DCOS(DAl)  INITAL 

CA2  =  DCOS (DA2)  INITAL 

IJ1  =  U+1  INITAL 

IH2  =  1J+2  INITAL 

IF  (IJ1.GT.3)  IJ 1=  IJ1-3  INITAL 

IF  (IJ2.GT.3)  I J2=  IJ2-3  INITAL 

SGN  =  1.0  INITAL 
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IF  (SA1.LT.0.0  .AND.  CA2.LT. 0.0)  SGN  =  -1.0 
Z(IJ  ,LK)  =  SGN*SA1»CA2 
Z(IJI,LK)  =  SGN»SA1*SA2 
Z ( I J  2 ,LK)  =  SGN»CA1*CA2 


Z(IJ1,LK)  =  SGN»SA1*SA2 
Z  ( I J  2 ,LK)  =  SGN»CA1*CA2 

53  IJ  =  J J 

54  LK  =  JK 

ZDOTIJ  =  Z ( 1 , IK) «Z ( 1 , JK) 
ZDOTII  =  Z ( I . IK) »Z ( 1 , IK) 
RATIO  =  ZDOTI J/ZDOTI I 
DO  55  1=1,3 

55  Z(I,JK)  =  Z(I,JK)  -  RATI 
LK  =  6-IK-JK 

IT  =  M0D(JK-IK+3 ,3) 

IF  (IT.EQ. 1)  CALL  CROS 
IF  (IT.EQ. 2)  CALL  CROS 
DO  57  K=  1 , 3 


+  Z (2 , IK) *Z ( 2 , JK) 
+  Z(2 , IK) *Z (2 , IK) 


Z (3 , IK) *Z (3 , JK) 
Z(3,IK)»Z(3,IK) 


RATI0*Z ( I , IK) 


IF  (IT.EQ. 1)  CALL  CROSS (Z ( I , IK) , Z ( 1 , JK) ,Z ( I , LK) ) 

IF  (IT.EQ. 2)  CALL  CROSS (Z(1,JK) , Z ( 1 , IK) , Z ( 1 , LK) ) 

DO  57  K=  1 , 3 
IYPR(K.J)  =  4-K 
SUM  =0.0 
DO  56  1=1,3 

56  SUM  =  SUM  +  Z ( I , K) *#2 
SQUM  =  DSQRT (SUM) 

DO  57  1=1,3 

57  D (K . I , J)  =  Z ( I , K) /SQUM 

CALL  YPRDEG  (D ( 1 , 1 , J) , YPR ( 1 , J) ) 

IF  (FIRST. EQ. 0.0)  WRITE  (6,58) 

58  FORMAT  CO  INITIAL  ANGULAR  ROTATIONS  COMPUTED  FROM  CARDS  G.3.J2’// 

»  ’  SEGMENT* , 1  OX, ’SEGMENT  PRIMARY  AXIS’ , 

»  12X, ’SEGMENT  SECONDARY  AXIS ’, 30X, ’ ANGULAR  ROTATIONS  (DEG)’ 

*  ’  NO.  SEG',9X,’Ar,8X,’A2’,8X,’A3’,llX,’Bl',8X,’B2’,8X, 

*  ’ B3 ’ , 7X , 'II  IK  JJ  JK' ,9X, ’YAW’ ,6X, ’PITCH’ ,5X, ’ROLL’/) 
FIRST  =  1.0 

WRITE  (6,59)  J,SEG(J) ,A,II,IK,JJ,JK,(YPR(I,J) ,1=1,3) 

59  FORMAT  ( 14 , IX , A4 , 3X , 3F10 . 3 , 3X , 3F 10 . 3 , 3X , 4 14 , 3X , 3F 10 . 3) 

60  M  =  IYPR(4 , J) 

IF  (M.EQ.O)  M=NGRND 

JF  (M.GE.J  .AND.  M.LE.NSEG)  STOP  24 

IF  (J.EQ. 1)  GO  TO  80 

IF  (M.LT.O  .AND.  -M. NE. IABS (JNT (J- 1) ) )  STOP  25 
80  CALL  DRCIJK  (D , YPR , I YPR , HT , J) 

IF  (I3.GT.0)  GO  TO  40 


JF  (M.GE.J 
IF  (J.EQ. 1 ) 
IF  (M.LT.O 
80  CALL  DRCIJK 
IF  (I3.GT.0) 


CALL  D0T3 1 (D ( 1 , 1 , NVEH) , WMEG ( 1 , NVEH) ,T) 
CALL  MAT3 1 ( D ( 1 , 1 , J ) ,T, WMEG ( 1 , J ) ) 

DO  39  1=1,3 

39  WMGDEG ( I , J)  =  WMEG ( I ,J) /RADIAN 

40  CONTINUE 
CALL  VEHPOS 
IF(NJNT.EQ.O)  GOTO  41 
CALL  CHAIN (0) 

CALL  EJOINT (1,0) 

DO  62  J= 1 , NJNT 


INITAL 

INITAL 

INITAL 

INITAL 

INITAL 

INITAL 

INITAL 

INITAL 

INITAL 

INITAL 

INITAL 

INITAL 

INITAL 

INITAL 

INITAL 

INITAL 

INITAL 

INITAL 

INITAL 

INITAL 

INITAL 

INITAL 

INITAL 

INITAL 

INITAL 

INITAL 

INITAL 

/INITAL 

INITAL 

INITAL 

INITAL 

INITAL 

INITAL 

INITAL 

INITAL 

INITAL 

VAXCHG 

INITAL 

VAXCHG 

INITAL 

INITAL 

INITAL 

INITAL 

INITAL 

INITAL 

-NITAL 

JDRIFT 

JDRIFT 

JDRIFT 

JDRIFT 


B 


1 


IF ( IABS (IPIN( J) ) . NE . 4)  GOTO  62  JDRIFT 

IF(IEULER(J) .WE. 2)  GOTO  62  JDRIFT 

DAI  =  ANG ( 2 , J )  +  CONST (2 , J)  JDRIFT 

CONST (4 , J)  =  DCOS(DAl)  JDRIFT 

CONST(5 , J )  =  DSIN(DAl)  JDRIFT 

62  CONTINUE  JDRIFT 

INITAL 

OUTPUT  INITIAL  BODY  SEGMENT  POSITIONS.  INITAL 

INITAL 

41  WRITE  (6,42)  UNITL , UNITL , UNITT  JDRIFT 

42  FORMAT ( ' 0  INITIAL  POSITIONS  (INERTIAL  REFERENCE) * ,70X, 'CARDS  G.2'/INITAL 

*  /’  SEGMENT’  .llX.'LINEAR  POSITION  ('fA4,')\  INITAL 

*  14X, ’LINEAR  VELOCITY  C ,A4, ’/’ ,A4, ’) ’/  AFREVS 

*  ’  NO.  SEG’ , 2 (9X, ’X’ , 1 IX, ’ Y’ ,11X,’Z’ , 5X)  )  INITAL 

WRITE  (6,43)  (J.SEG(J) , (SEGLP(I,J) ,1=1,3) , (SEGLV(I.J) ,1=1,3)  INITAL 

*  , J=1 ,NSEG)  INITAL 

43  FORMAT ( 14 , IX, A4 , 3X, 3F12 . 5 , 3X, 3F12 . C)  INITAL 

WRITE  (6,44)  UNITT  INITAL 

44  FORMAT ( ’ 0  INITIAL  ANGULAR  ROTATION  AND  VELOCITY’ ,71X, ’CARDS  G. 3 ’ //INITAL 

*  ’  SEGMENT’ ,11X,’ ANGULAR  ROTATION  (DEG) ’ ,  AFREVS 

*  14X, ’ANGULAR  VELOCITY  (DEG/’ ,A4, ’) ’/  INITAL 

*  ’  NO.  SEG’ ,8X, ’YAW’ ,8X, ’PITCH’ ,7X, ’ROLL’ ,  INITAL 

*  13X,’X’ ,1IX,’Y’ , 11X, ’Z' ,15X,’ IYPR’  )  INITAL 

WRITE  (6,46)  (J.SEG(J) , (YPR(I.J) ,1=1,3) , (WMGDEG(I.J) ,1=1,3) ,  INITAL 

*  (IYPR(I,J) ,1=1,4) ,J=1,NSEG)  INITAL 

46  FORMAT ( 14 , IX , A4 , 3X , 3F12 . 5 , 3X ,3F12 . 5 , 3X , 414)  INITAL 

IF  (I3.EQ.0)  WRITE  (6,45)  INITAL 

45  FORMAT ( ’ 0  LINEAR  AND  ANGULAR  VELOCITIES  HAVE  BEEN  SET  EQUAL  TO  THEINITAL 

*  INITIAL  VEHICLE  VELOCITIES.’)  INITAL 

IF  (NHRNSS.NE.O)  CALL  HBPLAY  INITAL 

IF  (II. EQ .15)  CALL  EQUILB  (YPR.IYPR)  INITAL 

CALL  UNIT  1(0)  JDRIFT 

CALL  ROTATE  INITAL 

CALL  ELTIME<2 ,2)  INITAL 

RETURN  INITAL 

END  INITAL 


t 


t 

i 

SUBROUTINE  INTERS<A,B,XM,T,X,V,AX)  INTERS  ! 

C  REV  IV  07/23/86TWOPI 


c 

DETERMINES  INTERSECTION  OF  ELLIPSOIDS 

INTERS 

c 

X' AX  =  1 

INTERS 

c 

(X’-M’)B(X-M)  =  1 

INTERS 

c 

WHERE  A  AND  B  ARE  ELLIPSOID  MATRICES 

INTERS 

c 

IF  T  ENTERS  AS  +1.0  ,  A  IS  EXTERNAL  TO  B  AND 

INTERS 

c 

AS  -1.0  ,  A  IS  INTERNAL  TO  B. 

INTERS 

c 

INTERS 

c 

IF  V  ENTERS  AS  NON-ZERO,  WILL  USE  PREVIOUS  VALUE  FOR  START. 

INTERS 

c 

(AX)  RETURNS  AS  (A)«(X). 

INTERS 

c 

INTERS 

c 

RETURNS  T> 1  -  NO  INTERSECTION 

INTERS 

c 

T< 1  -  INTERSECTION  IN  WHICH  CASE  X  WILL 

INTERS 

c 

CONTAIN  COORDINATES  OF  CONTACT  OF 

INTERS 

c 

CONTRACTED  ELLIPSOIDS. 

INTERS 

c 

INTERS 

IMPLICIT  REAL *8  (A-H.O-Z) 

INTERS 

DIMENSION  A(3 , 3) ,B(3,3) ,XM(3) ,X(3) 

INTERS 

DIMENSION  C (3 , 4) ,Z(3) ,BM(3) ,AX(3) ,AM(3) 

INTERS 

EQUIVALENCE  (Z(l) ,C(1 .4) ) 

INTERS 

COMMON/CNSNTS/  PI .RADI AN ,G, THIRD .EPS (24) , 

INTERS 

*  UNITL . UNITM.UNITT ,QRAVTY(3) .TWOPI 

TWOPI 

c 

INITIALIZATION 

INTERS 

c 

EVALUATE  BM.M’AM.M'BM 

INTERS 

c 

SET  N=0 ,  V=K'BM/M’ AM 

INTERS 

N  =  0 

INTERS 

BMM  =  0.0 

INTERS 

AMM  =0.0 

INTERS 

DO  11  1=1,3 

INTERS 

BM( I )  =  0.0 

INTERS 

AM( I )  =  0.0 

INTERS 

DO  10  J=  1 , 3 

INTERS 

IF  ( DABS ( A ( I , J ) ) . LT . EPS ( 20 ) )  A(I,J)  =  0.0 

INTERS 

AM( I )  =  AM( I )  +  A(I,J)*XM(J) 

INTERS 

IF  ( DABS ( B ( I , J ) ) . LT . EPS ( 20 ) )  B(I,J)  =0.0 

INTERS 

10 

BM( I )  =  BM( I )  +  B(I,J)*XM(J) 

INTERS 

BMM  =  BMM  +  XM( I ) *BM( I ) 

INTERS 

11 

AMM  =  AMM  +  XM( I ) »AM( I ) 

INTERS 

IF  (V.EQ.0.0)  V= T * DSQRT ( BMM/ AMM) 

INTERS 

IDONE  =  0 

INTERS 

c 

NEWTON- RAPHSON  ITERATION  FOR 

INTERS 

c 

G(V)  =  FA (V) -FB (V)  =  0 

INTERS 

c 

SOLVE  (VA+B) X  =  BM  FOR  X 

INTERS 

ITER  =  0 

INTERS 

20 

ITER  =  ITER+1 

INTERS 

DO  22  1=1,3 

INTERS 

DO  21  J=1 ,3 

INTERS 

21 

C ( I , J)  =  V*A(I , J)  +  B  Cl , J) 

INTERS 

22 

Z(I)  =  BMC  I ) 

INTERS 

275 
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CALL  DSMSOL (C , 3 , 3) 

EVALUATE  AX 

FA(V)  =  X* AX 

FB  (V)  =  -V(X' -M‘ ) AX 

FA  =  0.0 
FB  =  0.0 

CALL  MAT31 (A.Z.AX) 

DO  30  1=1,3 
X  ( I )  =  Z(I) 

FA  =  FA+X(I)*AX(I) 

30  FB  =  FB+ (X(I) -XM( I ) ) »AX(I ) 

FB  =  -V*FB 

IF  (T.LT.O.O)  FA  =  1.0/FA 
IF  (IDONE.EQ. 1)  GO  TO  60 

TEST  FOR  INTERSECTION 

IF  (FA-FB)  32,60,31 

IF  FA>FB> 1 ,  NO  INTERSECTION 

31  IF  (T.GT.O.O.AND.FB.LT. 1.0)  GO  TO  40 
IF  (T.LT.O.O.AND.FA.GT. 1.0)  GO  TO  40 
IF  (N.EQ.O)  GO  TO  60 

GO  TO  62 


IF  FA<FB< 1  ,  INTERSECTION 


32  IF  (T.GT.O.O.AND.FB.LE. 1.0)  N=1 
IF  (T.LT.O.O. AND . FA.GE . 1 . 0)  N=1 


SOLVE  (VA+B1Z 


FOR  Z 


40  DO  42  1=1,3 
DO  41  J= 1 , 3 

41  C(I.J)  =  V*A(I,J)  +  B (I , J) 

42  Z ( I )  =  AX ( I ) 

CALL  DSMSOL (C, 3, 3) 


-2X’AZ 


CALL  MAT31  (A.Z.AX) 


FPA  = 

X  ( 1 ) *AX( 1 ) 

+ 

X(2) * AX ( 2 ) 

+ 

X(3)»AX(3) 

FPA  = 

-  (FPA+FPA) 

DV  = 

1.0  +  V 

IF  (T 

. LT.O.O)  DV 

DV  =  -G(V)/G’ (V) 


DV  =  (FB-FA) / (DV*FPA) 

IF  (ITER. GE. 50)  GO  TO  62 


TEST  FOR  CONVERGENCE 


IF  (TMV+DV)  .LE.O.O)  DV  =  -0.5»V 


V  =  V+DV 
DV  =  DABS (DV/V) 

IF  (DV.LE.EPS( 12) )  ID0NE=1 
GO  TO  20 


FA(V)  =  FB(B)  ,  RETURN 


60  IF  (T.LT.O.O)  FA  =  1.0/FB 


=  DSQRT(FA) 


^ . ^ . .,r . . , . 
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INTERS 

INTERS 

INTERS 

INTERS 
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INTERS 

INTERS 

INTERS 

INTERS 

INTERS 

INTERS 

INTERS 

INTERS 

INTERS 

INTERS 

INTERS 

INTERS 

INTERS 

INTERS 

INTERS 

INTERS 

INTERS 

INTERS 

INTERS 

INTERS 

INTERS 
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INTERS 

INTERS 

INTERS 

INTERS 
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IF  (FA.GT.1.0)  GO  TO  61  INTER S 

N  =  1  INTEBS 

GO  TO  71  INTEBS 

61  IF  (N.EQ.O)  GO  TO  71  INTEBS 

62  WBITE  (6,63)  INTEBS 

63  FORMAT (’  INTERS  ITERATION  DID  NOT  CONVERGE’)  INTERS 

71  CONTINUE  INTERS 

RETURN  INTERS 

END  INTEBS 


SUBROUTINE  KINPUT  KINPUT 

REV  IV  07/23/86TWOPI 

PERFORMS  THE  FOLLOWING  CARD  INPUT  AFTER  CARDS  E.1-E.4  (SUBROUTINE  KINPUT 
CINPUT)  AND  BEFORE  CARDS  F.1-F.5  (SUBROUTINE  FINPUT) .  KINPUT 

CARD  E.5  -  NO  LONGER  REQUIRED  WINDOP 

CARDS  E . 6  -  DEFINITIONS  OF  WIND  FORCE  FUNCTIONS  AND  DRAG  WINDOP 

COEFFICIENT  FUNCTIONS  WINDOP 

CARDS  E.7  -  DEFINITIONS  OF  JOINT  RESTORING  FORCE  FUNCTIONS  KINPUT 

KINPUT 

IMPLICIT  REAL#8 (A-H.O-Z)  KINPUT 

COMMON/CONTRL/  T I ME , NSEG , N JNT , NPL , NBLT , NBAG , NVEH , NGRND ,  KINPUT 

«  NS , NQ , NSD , NFLX , NHRNSS , NWINDF , NJNTF , NPRT (36) , NPG  PAGE 

COMMON/TABLES/MXNTI ,MXNTB,MXTB1 .MXTB2.NTI (50) ,NTAB(1250) , TAB (4500) DIMENB 
COMMON/CNSNTS/  PI .RADIAN, G.THIRD.EPS (24) ,  KINPUT 

*  UNI TL , UN I TM , UN I TT , GRAVT Y ( 3 ) , TWOP I  TWOPI 

COMMON/ TITLES/  DATE(3) ,COMENT(40) ,VPSTTL(20) ,BDYTTL(5) ,  WINDOP 

*  BLTTTL(5,8) ,PLTTL(5,30) ,BAGTTL(5,6) ,SEG(30) ,  WINDOP 

*  J0INT(30) ,CGS(30) ,JS(30)  WINDOP 

REAL  DATE . COMENT . VPSTTL , BDYTTL , BLTTTL , PLTTL , BAGTTL , SEG .JOINT  TGMOD 1 

COMMON/TEMPVS/  JTITLE (5 , 5 1 ) ,NF (5) , MS (3) , KTITLE (31 ) ,TH(50)  KINPUT 

NOTE:  TEMPVS  IS  SHARED  HERE  WITH  SUBROUTINES  CINPUT  AND  FINPUT.  KINPUT 
REAL  BLANK .JTITLE, KTITLE  KINPUT 

DATA  BLANK/4H  /  KINPUT 

11  FORMAT (216)  KINPUT 

J1  =  MXTB1+1  KINPUT 

IF  (NWINDF. LE.O)  GO  TO  31  KINPUT 

DO  30  K= 1 .NWINDF  KINPUT 

KINPUT 

INPUT  CARD  E.6.A  -  FUNCTION  NO.  AND  TITLE  KINPUT 

KINPUT 

READ  (5,12)  I , (KTITLE (J) , J= 1 , 5)  KINPUT 

12  FORMAT ( 1 4 , 4X , 5A4 )  KINPUT 

WRITE  (6,13)  I , (KTITLE (J) ,J=1,5) , I ,J1 ,NPG  PAGE 

NPG=NPG+ 1  PAGE 

13  FORMAT ( ’ 1  WIND  FORCE  FUNCTION  NO. ’ , 14 ,4X, 5A4 , 10X, ’NTI ( ’ , 12 , ’ )  =  ’,  KINPUT 

*  I5.46X, ’PAGE’ .I5/120X, ’CARDS  E.6'/)  PAGE 

IF  (I. LE.O. OR. I. GT. 50)  WRITE  (6,14)  KINPUT 

14  FORMAT ( ’ 0  IMPROPER  FUNCTION  NO.  PROGRAM  TERMINATED.’)  KINPUT 

IF  (I. LE.O. OR. I. GT. 50)  STOP  11  KINPUT 

IF  (NTI (I) .NE.O)  WRITE  (6,15)  I  KINPUT 

15  FORMAT ( ' 0  FUNCTION  NO. ’,14,’  HAS  ALREADY  BEEN  INPUTTED  AND  WILL  BEKINPUT 

*  REPLACED  BY  THIS  FUNCTION.’)  KINPUT 

NTI (I)  =  J1  KINPUT 

DO  16  J= 1 , 5  KINPUT 

16  JTITLE (J , I )  =  KTITLE(J)  KINPUT 

J2  =  Jl+4  KINPUT 

KINPUT 

INPUT  CARD  E.6.B  WINDOP 

WINDOP 

READ  (5,60)  (TAB(J) ,J=J1 ,J2-2) .NSV.NSR  WINDOP 


o  o  o  o  o  o 


i 

I 

i 

I 
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60  FORMAT(3F12. 0,2112) 

TAB ( J2- 1 )  =  DFLOAT (NSV) 

TAB (J2)  =  DFLOAT (NSB) 

IF  (TAB(Jl) .EQ. 0.0)  GOTO  22 

WRITE (6 , 23)  (TAB ( J) ,J=J1 ,J2-2) ,NSV , SEG(NSV) .NSR.SEG(NSR) 

23  FORMAT ( ’  SPEC.  HEAT  RATIO  SONIC  VEL.  ABS.  PRESS. \7X, 

*  'SEGMENT  REF.  SEGMENT ’ , /3F15 . 4 , 2 (1 1 1 , A4) //) 

J1=J2+ 1 

GOTO  30 

22  WRITE  (6,18)  (TAB ( J) , J=J1 , J2) 

17  F0RMAT(6F12 . 0) 

18  FORMAT ( 10X . ’ DO ’ , 13X , ’ D1 ' , 13X, ’ D2 ’ , 13X , ’ D3 ’ , 8X, 1  REF.  SEGMENT’, 

*  /5F15.4//) 

J1  =  J2+1 

INPUT  CARD  E.6.C  -  NTMPTS 

READ  (5,11)  NTMPTS 

WRITE  (6,19)  NTMPTS 

19  FORMAT ( ’ 0  WIND  FORCE  TABLES  FOR  ’,16,’  TIME  POINTS.’// 

»  1 IX , ’ T ’ , 14X, ’ FX(T) ’ , 15X, ’ FY(T) ’ , 15X, ’FZ (T) ’  /) 

TAB(Jl)  =  NTMPTS 
J1  =  Jl  +  1 

J2  =  J1+4*NTMPTS-1 

INPUT  CARDS  E.6.D-E.6.N  -  NTMPTS  CARDS  OF  T,FX(T) ,FY(T) ,FZ(T) 

READ  (5,20)  (TAB(J) , J=J1 , J2) 

WRITE  (6,21)  (TAB (J) , J=J1 , J2) 

20  FORMAT (4F12.0) 

21  FORMAT ( 3X , F 1 2 . 6 , 3G20 . 6 ) 

J1  =  J2+ 1 

30  CONTINUE 

31  IF  (NJNTF.LE.O)  GO  TO  51 
DO  50  K= 1 .NJNTF 

C 

C  INPUT  CARD  E.7.A  -  FUNCTION  NO.  AND  TITLE 

C 

READ  (5,12)  I. (KTITLE(J) . J= 1 , 5) 

WRITE  (6,32)  I , (KTITLE(J) , J  = 1 , 5 ) , I ,J1 ,NPG 
NPG=NPG+ 1 

32  FORMAT ( ’ 1  JOINT  FORCE  FUNCTION  NO . ’,14 , 4X, 5A4 , 10X, ’NTI ( ’ , 12 , ’ ) 

*  15, 45X, ’PAGE’ .I5/120X, ’CARDS  E.7’/) 

IF  (I .LE.O.OR. I .GT.50)  WRITE  (6,14) 

IF  (I .LE.O.OR. I .GT.50)  STOP  12 
IF  (NTI (I) .NE.O)  WRITE  (6,15)  I 
NT I ( I )  =  J1 
DO  33  J=i  ,5 

33  JTITLE ( J , I )  =  KTITLE(J) 


i 

} 

WINDOP 

windop  ; 

WINDOP  ! 

windop  ; 

WINDOP 

WINDOP 

WINDOP 

WINDOP  ! 

MI  SC 

K INPUT  ! 

K INPUT  j 

WINDOP  ! 

WINDOP 
KINPUT 
K INPUT 

KINPUT  I 

KINPUT 

KINPUT  | 

KINPUT 

KINPUT  j 

KINPUT  I 

KINPUT 

KINPUT 

KINPUT 

KINPUT 

KINPUT 

KINPUT 

KINPUT 

KINPUT 

KINPUT 

KINPUT 

KINPUT 

KINPUT 

KINPUT 

KINPUT 

KINPUT 

KINPUT 

KINPUT 

KINPUT 

PAGE 

PAGE 

=’ .KINPUT 
PAGE 
KINPUT 
KINPUT 
KINPUT 
KINPUT 
KINPUT 
KINPUT 
KINPUT 


INPUT  CARD  E.7.B  -  DO ,D1 ,D2 ,D3  tD4  (FOR  NOW  A  BLANK  CARD).  KINPUT 

K INPUT 

J 2  =  Jl+4  KINPUT 

READ  (5,17)  (TAB(J) ,  J=J1 , J2)  KINPUT 

WRITE  (6,18)  (TAB(J) ,J=J1 ,J2)  KINPUT 

J1  =  J2+1  KINPUT 

KINPUT 

INPUT  CARD  E.7.C  -  NTHETA , NPHI  KINPUT 

KINPUT 


READ  (5,11)  NTHETA, NPHI 
TAB ( J1  )  =  NTHETA 
TAB(J1+1)  =  NPHI 
J1  =  Jl+2 

IF  (NTHETA. LT.O)  GO  TO  38 
DO  35  J=l, NTHETA 

35  TH(J)  =  DFLOAT ( J- 1 ) *  1 80 . 0/DFLOAT (NTHETA- 1 ) 

WRITE  (6,36)  NTHETA, NPHI,  (THU)  ,J=2, NTHETA) 

36  FORMAT ( ' 0  FUNCTION  IS  TABULAR  FOR*  ,13,’  X’,I3,’ 


KINPUT 

KINPUT 

KINPUT 

KINPUT 

KINPUT 

KINPUT 

KINPUT 

KINPUT 

VALUES  OF  THETA  AK INPUT 


*ND  PHI ’ / /30X, ’ THETA’ /5X, ’ PHI ' , 5X, ’THETAO’ ,F16 . 3 , 4F20 . 3/ 

*  (15X.5F20.3)) 

37  FORMAT (F9 . 2 . F10 . 3 , 5G20 . 7/ ( 19X , 5G20 . 7) ) 

GO  TO  40 

38  NPOLY  =  -NTHETA  -1 

WRITE  (6,39)  NPOLY. NPHI. (BLANK, J,J=1, NPOLY) 

39  FORMAT ( ’0  FUNCTION  IS  COEFFICIENTS  OF'  ,13, 

»( THETA- THETAO)  FOR ’,13,’  VALUES  OF  PHI.’// 

*  27X, ’COEFFICIENTS  OF  (THETA-THETAO) **N’ / 

»  5X, ’PHI’ ,5X, ’THETAO’ ,7X,5(A4, ’N  = ’ , 12 , 1 IX) / (26X, A4 , 'N 

*  A4 , ’ N  =’ ,12, 11X.A4, 'N  = ’ , 12, 1 IX, A4 , ’N  = ’ , 12 , 1 1X.A4 , *N 

40  WRITE  (6,21) 

DO  49  1=1, NPHI 

PHIDEG  =  DFLOAT ( I- 1) »360 . O/DFLOAT ( NPHI)  -  180.0 


INPUT  CARDS  E.7.D  -  E.7.N  NPHI  SETS  WITH  NTHETA  ITEMS  PER  SET. 
EACH  SET  I  IS  FOR  PHI (I)  =  -180  + (I- 1) »360/NPHI  DEGREES  AND 
ASSUMES  DATA  FOR  PHKNPHI  +  l)  =  180  IS  SAME  AS  PHI(l)  =  -180. 


KINPUT 
KINPUT 
KINPUT 
KINPUT 
KINPUT 
KINPUT 

ORDER  POLYNOMIALS  IN  KINPUT 

KINPUT 
KINPUT 
,12,1 1X.KINPUT 


,12)  ) 


J2  =  J 1  +  IABS (NTHETA)  -1 
READ  (5,17)  (TAB (J) , J=J1 , J2) 

WRITE  (6,37)  PHIDEG, (TAB(J) ,J=J1,J2) 

IF  (NTHETA. LT.O)  TAB(Jl)  =  TAB (J1 ) * RADIAN 
IF  (NTHETA. LT.O)  GO  TO  49 

FOR  TABULAR  DATA,  FILL  IN  ZERO  VALUES  WITH  INTERPOLATED  NEGATIVE 
VALUES.  OVERWRITE  VALUE  IN  FIRST  COLUMN  (SUPPLIED  AS  THETAO)  WITH  KINPUT 


KINPUT 
KINPUT 
KINPUT 
KINPUT 
KINPUT 
KINPUT 
KINPUT 
KINPUT 
KINPUT 
X INPUT 
KINPUT 
KINPUT 
KINPUT 
KINPUT 
KINPUT 
KINPUT 


VALUE  FOR  THETA  =  0  AND  ALL  OTHER  ZERO  VALUES. 

THETAO  =  TAB ( J 1 ) 

IF  (THETAO. EQ. 0.0)  GO  TO  49 

JJ  =  THETAO«DFLOAT (NTHETA- 1)/ 180.0  +  1.0  +  EPS (6) 


KINPUT 

KINPUT 

KINPUT 

KINPUT 

KINPUT 


I  Wl  m  I  AIM  mx  0in  \  Ul  if  l  w-m-ib  w  wiL»!*n"iuw  iwiuw  i  jwiwuwi: 


45 

46 

47 


49 

50 

51 


JJ1  =  Jl+JJ  KINPUT 

I ERROR  =  0  KINPUT 

IF  (JJ1.GT.J2)  I ERROR  =  1  KINPUT 

IF  (TAB(JJl) .LE.0.0)  I ERROR  =  2  KINPUT 

IF  (IERR0R.NE.0)  GO  TO  46  KINPUT 

DO  45  J=1,JJ  KINPUT 

J1J  =  Jl+J-1  KINPUT 

IF  (J.NE. l.AND.TAB(JlJ) .GT.0.0)  IERROR  =  3  KINPUT 

TAB(JIJ)  =  TAB(JJl) * (TH(J) -THETAO) / (TH(JJ+1) -THETAO)  KINPUT 

IF  (IERROR. NE.O)  WRITE  (6,47)  IERROR  KINPUT 

FORMAT ( ’ 0  INPUT  ERROR.  INCONSISTENT  VALUE  OF  THETAO.  IERROR  12. KINPUT 

*  ’  PROGRAM  TERMINATED. *)  KINPUT 

IF  (IERROR. NE.O)  STOP  13  KINPUT 

J1  =  J2+ 1  KINPUT 

CONTINUE  KINPUT 

MXTB1  =  J 1 - 1  KINPUT 

RETURN  KINPUT 

END  KINPUT 


SUBROUTINE  LINAXS (XO , YO .THETA , NINTVS , TOTLGT)  LINAXS 

REV  18  02/28/78LINAXS 

PURPOSE  :  PREPARE  A  LINEAR  AXIS  ON  A  PLOT.  LINAXS 

LINAXS 

DESCRIPTION  OF  PARAMETERS:  LINAXS 

XO , YO  -  STARTING  POINT  (IN  INCHES,  REL  TO  PLOTTER  ORIGIN).  LINAXS 

LINAXS 

THETA  -  ANGLE  OF  AXIS,  IN  DEGREES.  LINAXS 

LINAXS 

NINTVS-  MAGNITUDE  =  NO.  OF  INTERVALS  DELINEATED  BY  TIC  MARKS.  LINAXS 
-  SIGN  DETERMINES  WHETHER  TIC  MARKS  ARE  PLACED  ON  LINAXS 

POSITIVE  OR  NEGATIVE  SIDE  OF  AXIS.  RESPECTIVELY  LINAXS 

(POSITIVE  SIDE  IS  TO  LEFT  OF  DIRECTION  OF  TRAVEL) .  LINAXS 

LINAXS 

TOTLGT-  TOTAL  LENGTH  OF  AXIS.  IN  INCHES.  LINAXS 

LINAXS 

SUBROUTINES  REQUIRED  :  SIN,  COS,  PLOT  (NOTE:  SINGLE  PRECISION).  LINAXS 

LINAXS 

AUTHOR:  W.  D.  FRYER,  CALSPAN  (MARCH  1967).  LINAXS 

LINAXS 

PLAGIARIZED  FROM  CALSPAN  SUBROUTINE  LIBRARY  (NO.  CU  0035).  LINAXS 

LINAXS 

THR  =  1 . 7453293E-2  «  THETA  LINAXS 

SINT  =  SIN (THR)  LINAXS 

COST  =  COS (THR)  LINAXS 

LINAXS 

DL  =  ABS (TOTLGT/  FLOAT (NINTVS) )  LINAXS 

DX  =  DL*COST  LINAXS 

DY  =  DL»SINT  LINAXS 

LINAXS 

TICX  =  -0.12*  SINT  LINAXS 

TICY  =  0.12*  COST  LINAXS 

IF (NINTVS.GT.O)  GO  TO  30  LINAXS 

TICX  =  -TICX  LINAXS 

TICY  =  -TICY  LINAXS 

LINAXS 

30  X  =  XO  LINAXS 

Y  =  YO  LINAXS 

LINAXS 

CALL  PLOT  (X  +TICX.Y+TICY.3)  LINAXS 

CALL  PLOT  (X,Y,2)  LINAXS 

HINT  =  I ABS (NINTVS)  LINAXS 

DO  40  1=1 ,NINT  LINAXS 

X  =  X+DX  LINAXS 

Y  =  Y+DY  LINAXS 

CALL  PLOT(X, Y,2)  LINAXS 

CALL  PLOT(X+TICX, Y+TICY, 2)  LINAXS 

40  CALL  PL0T(X,Y,2)  LINAXS 

LINAXS 

RETURN  LINAXS 

END  LINAXS 


SUBROUTINE  LOGAXS (XO ,YO .THETA, NDEC , EXTENT)  LOGAXS 

REV  19  09/ 18/79LOGAXS 

PURPOSE  :  PREPARE  LOGARITHMIC  AXIS  ON  A  PLOT.  LOGAXS 

LOGAXS 

DESCRIPTION  OF  PARAMETERS:  LOGAXS 

LOGAXS 

XO.YO  -  STARTING  POINT  (IN  INCHES,  REL  TO  PLOTTER  ORIGIN).  LOGAXS 

LOGAXS 

THETA  -  ANGLE  OF  AXIS  (DEGREES) .  LOGAXS 

LOGAXS 

NDECS  -  MAGNITUDE  OF  NDECS  SPECIFIES  NO.  OF  DECADES.  LOGAXS 

-  SIGN  DETERMINES  WHETHER  TIC  MARKS  ARE  TO  BE  PLACED  LOGAXS 
ON  POS.  OR  NEG.  SIDE  OF  AXIS.  RESP.  (POS.  SIDE  IS  LOGAXS 

TO  LEFT  OF  PREDOMINANT  DIRECTION  OF  TRAVEL) .  LOGAXS 

LOGAXS 

EXTENT-  MAGNITUDE  OF  EXTENT  SETS  OVER- ALL  LENGTH  OF  AXIS  LOGAXS 

IN  INCHES.  IF  EXTENT  IS  POSITIVE,  TIC  MARKS  ARE  LOGAXS 

SPACED  NORMALLY  (LARGE  INTERVALS  FIRST) .  IF  EXTENT  LOGAXS 
IS  NEGATIVE,  TIC  MARKS  ARE  SPACED  IN  REVERSE  ORDER  LOGAXS 
(SMALL  INTERVALS  FIRST) .  LOGAXS 

LOGAXS 

SUBROUTINES  REQUIRED  :  SIN,  COS,  PLOT  (NOTE:  SINGLE  PRECISION).  LOGAXS 

LOGAXS 

AUTHOR:  W.  D.  FRYER.  CALSPAN  (MARCH  1967).  LOGAXS 

LOGAXS 

PLAGIARIZED  FROM  CALSPAN  SUBROUTINE  LIBRARY  (NO.  CU  0036) .  LOGAXS 

LOGAXS 

LOGICAL  REVERS  LOGAXS 

REAL  XL(18) ,XL0(19)  LOGAXS 

EQUIVALENCE  (XL0(2) ,XL(1))  LOGAXS 

DATA  XLO/  0.0  ,  0.17609,  0.30103,  0.39794,  0.47712,  0.54407,  LOGAXS 

*  0.60206,  0.85321,  0.69897,  0.74036,  0.77815,  0.81291.  0.84510,  LOGAXS 

»  0.87506,  0.90309,  0.92942,  0.95424,  0.97772,  1.0  /  LOGAXS 

DATA  RPD  / 1 . 7453293E-2/  LOGAXS 

LOGAXS 

LOGAXS 

REVERS  =  .FALSE.  LOGAXS 

IF (EXTENT.LT. 0.0)  REVERS  =  .TRUE.  LOGAXS 

LOGAXS 

NODEC  =  I ABS (NDEC)  LOGAXS 

SPDEC  =  ABS (EXTENT)  /  FLOAT (NODEC)  LOGAXS 

THR  =  THETA«RPD  LOGAXS 

COST  =  COS (THR)  LOGAXS 

SINT  =  SIN(THR)  LOGAXS 

LOGAXS 

TICX1  =-0 . 05*SINT  LOGAXS 

TICY1  =  0 . 05«C0ST  LOGAXS 

TICXA  =  -0 . 12*SINT  LOGAXS 

TICXB  =  -0 . 20*SINT  LOGAXS 


s 


TICYA  =  0 . 12*C0ST 
TICYB  =  0.20»COST 
IF(NDEC.GT.O)  GO  TO  50 


TICX1 

TICY1 

TICX2 

TICXA 

TICYA 

TICXB 

TICYB 


-TICX1 

-  TICY1 
-TICX2 

-  TICXA 
-TICYA 
-TICXB 

-  TICYB 


50  COST  =  COST»SPDEC 
SINT  =  SINT»  SPDEC 
TICX2  =  TICXA 
TICY2  =  TICYA 


XD  =  XO 
YD  =  YO 
ND  =  I 
N  =  0 

***»»G0  TO  START  POS.****» 
CALL  PLOT (XO+TICXB , Y0+TICYB.3) 
CALL  PLOT (X0,Y0,2) 

60  N  =  N+l 
Q  =  XL (N) 

IF (.NOT.  REVERS)  GO  TO  65 
M  =  18-N 
Q  =  l.O-XL(M) 

65  X  =  XD  +  Q*COST 

Y  =  YD  +  Q»SINT 
CALL  PLOT (X , Y , 2) 

CALL  PLOT (X+TICX1 , Y+TICY1 , 2) 
CALL  PLOT  (X,Y,2  ) 

N  =  N+I 
Q  =  XL (N) 

IF (.NOT.  REVERS)  GO  TO  75 
M  =  18-N 
Q  =  1.0  -  XL (M) 

75  X  =  XD  ♦  Q»COST 

Y  =  YD  +  Q»SINT 
CALL  PL0T(X,Y,2) 

CALL  PLOT  (X+TICX2 , Y+TICY2 ,2) 
CALL  PL0T(X,Y,2) 

IF (N- 16)  60,80,100 


LOGAXS 

LOGAXS 

LOGAXS 

LOGAXS 

LOGAXS 

LOGAXS 

LOGAXS 

LOGAXS 

LOGAXS 

LOGAXS 

LOGAXS 

LOGAXS 

LOGAXS 

LOGAXS 

LOGAXS 

LOGAXS 

LOGAXS 

LOGAXS 

LOGAXS 

LOGAXS 

LOGAXS 

LOGAXS 

LOGAXS 

LOGAXS 

LOGAXS 

LOGAXS 

LOGAXS 

LOGAXS 

LOGAXS 

LOGAXS 

LOGAXS 

LOGAXS 

LOGAXS 

LOGAXS 

LOGAXS 

LOGAXS 

LOGAXS 

LOGAXS 

LOGAXS 

LOGAXS 

LOGAXS 

LOGAXS 

LOGAXS 

LOGAXS 

LOGAXS 

LOGAXS 

LOGAXS 

LOGAXS 

LOGAXS 

LOGAXS 


* 


80  TICX2  =  TICXB  LOGAXS 

TICY2  =  TICYB  LOGAXS 

GO  TO  60  LOGAXS 

LOGAXS 

100  IF  (ND  .EQ.  NODEC)  GO  TO  200  LOGAXS 

TICX2  =  TICXA  LOGAXS 

TICY2  =  TICYA  LOGAXS 

N  =  0  LOGAXS 

XD  =  X  LOGAXS 

YD  =  Y  LOGAXS 

ND  =  ND+1  LOGAXS 

GO  TO  60  LOGAXS 

LOGAXS 

200  RETURN  LOGAXS 

END  LOGAXS 


.k 


$ 

««r 

A 
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%  uvvv, 


FUNCTION  LTIME(N)  LTIME 

REV  I I I. 2  08/08/84REVIII 
TEMPORARY  FORTRAN  VERSION  OF  S/370  ASSEMBLER  LANGUAGE  ROUTINE  FROMLTIME 


CALSPAN  LIBRARY  THAT  MEASURES  ELAPSED  CPU  TIME  IN  UNITS  OF  0.01 
SECONDS.  IT  SHOULD  BE  REPLACED  WITH  AN  EQUIVALENT  ROUTINE  BY  THE 
USER  TO  ENABLE  SUBROUTINE  ELTIME  TO  PERFORM  ON  HIS  COMPUTER. 

ORIGINAL  CALSPAN  ROUTINE  PERFORMS  AS  FOLLOWS: 

IT  =  LTIME(O)  GIVES  ELAPSED  CPU  TIME  (INTEGER  NUMBER  OF  0.01 
SECOND  UNITS)  SINCE  SUBROUTINE  REFERENCE  WAS 
RESET,  AND  RESETS  THIS  REFERENCE. 

IT  =  LTIME ( 1 )  SAME,  EXCEPT  THAT  THE  REFERENCE  IS  NOT  RESET. 


THIS  SUBROUTINE  DOESN’T  WORK  WITH  THE  P-E  COMPUTER 
BUT  THE  CODE  IS  LEFT  HERE  AS  A  DUMMY  SUBROUTINE. 
HOWEVER,  THERE  IS  A  VERSION  OF  THIS  SUBROUTINE  THAT 
CAN  BE  USED,  BUT  IT  CAN  ONLY  BE  COMPILED  WITH  THE 
P-E  FORTRAN  0  COMPILER.  THE  OBJECT  DECK  FOR  THIS 
SUBROUTINE  IS  KEPT  SEPARATELY  AND  INCLUDED  IN  THE 
TASK  FILE  WHEN  THE  PROGRAM  IS  LINKED 

DATA  KTIME/O/ 

KTIME  =  KTIME+ 1 

LTIME  =  KTIME 

IF  lN.EQ.0)  KTIME  =  0 

RETURN 

END 


LTIME 

LTIME 

LTIME 

LTIME 

LTIME 

LTIME 

LTIME 

LTIME 

LTIME 

LTIME 

PECONV 

PECONV 

PECONV 

PECONV 

PECONV 

PECONV 

PECONV 

PECONV 

PECONV 

LTIME 

LTIME 

LTIME 

LTIME 

LTIME 

LTIME 


%v%r.v' 


c 

c 

c 

c 


SUBROUTINE  MAT33  (A.B.C) 

PERFORMS  MATRIX  MULTIPLICATION  C  =  AB 
WHERE  A,  B  AND  C  ARE  ALL  3X3  MATRICEES. 


REV  17 


IMPLICIT  REAL* 8  (A-H.O-Z) 

DIMENSION  A(3 ,3)  ,  B(3,3)  .  C(3.3) 

DO  10  1=1,3 

DO  10  J=1 ,3 

10  C  ( I .  J)  =  A( 1 , 1 ) *B ( 1 , J)  ♦  A(1 , 2) *B(2 , J)  ♦  A(1 ,3) *B(3,J) 
RETURN 
END 


MAT33 

01/03/77MAT33 

MAT33 

MAT33 

MAT33 

MAT33 

MAT33 

MAT33 

MAT33 

MAT33 

MAT33 

MAT33 


SUBROUTINE  ORTHO(P,X,L) 

ORTHO 

c 

REV 

03 

05/31/730RTHO 

c 

GENERATES  A  SET  OF  RIGHT 

HANDED  ORTHONORMAL  VECTORS 

(P)  . 

ORTHO 

c 

GIVEN  ONE  OF  THE  VECTORS 

(X) ,  WHERE 

ORTHO 

c 

P  -  LX3  MATRIX  OF  3 

ORTHONORMAL  VECTORS  TO 

BE  GENERATED. 

ORTHO 

c 

X  -  GIVEN  VECTOR. 

ORTHO 

c 

L  -  1ST  SUBSCRIPT  OF  P  IN  CALLING  PROGRAM. 

ORTHO 

c 

ORTHO 

IMPLICIT  REAL»8 (A-H ,0-Z) 

ORTHO 

DIMENSION  P (L , 3) ,X(3) 

ORTHO 

M=2 

ORTHO 

N=3 

ORTHO 

TEST=0 . 

ORTHO 

DO  5  1-1,3 

ORTHO 

P(I ,3) -X(l) 

ORTHO 

D=1.-X(I)*«2 

ORTHO 

IF (D.LE.TEST)GO  TO  4 

ORTHO 

TEST=D 

ORTHO 

D=DSQRT (D) 

ORTHO 

P  ( 1 , 1 ) =D 

ORTHO 

P  (1 , 2) =0. 

ORTHO 

P(M,2)=X(N)/D 

ORTHO 

P (N, 2) =-X(M) /D 

ORTHO 

P(M, 1 ) =X( I ) *P (N , 2) 

ORTHO 

P(N,1)=-X(I)*P(M,2) 

ORTHO 

4  M=N 

ORTHO 

N=I 

ORTHO 

5  CONTINUE 

ORTHO 

RETURN 

ORTHO 

END 

ORTHO 

'•V 


MM 


SUBROUTINE  OUTPUT (IJK)  OUTPUT 

BET  IT  02/01/88MISDOT 

CONTROLS  TABULATED  OUTPUT  ON  FORTRAN  UNITS  (STARTING  WITH  NO.  21)  OUTPUT 
OF  SELECTED  OPTIONAL  SEGMENT  LINEAR  AND  ANGULAR  ACCELERATIONS,  OUTPUT 
TELOCITIES  AND  DISPLACEMENTS,  JOINT  PARAMETERS  AND  SELECTED  DATA  OUTPUT 


OUTPUT 

OUTPUT 


FROM  ALL  ALLOWED  CONTACT  FORCE  COMPUTATIONS  BETWEEN  BODY  SEGMENTS  OUTPUT 


AND  VEHICLE  COMPONENTS. 


OUTPUT 
OUTPUT 

IMPLICIT  REAL *8  (A-H.O-Z)  OUTPUT 

COMMON/CONTRL/  TIME, NSEG , NJNT , NPL , NBLT . NBAG , NVEH , HGRND ,  OUTPUT 

*  NS , NQ , NSD , NFLX , NHRNSS , NWINDF , NJNTF , NPRT ( 36) , NPG  PAGE 

COMMON/CMATRX/  VI (3,30) ,V2(3,30) . V3 (3 . 12) ,B12(3,3,60) ,A22 (3,3,60) .OUTPUT 

*  F(3,30) , TQ (3, 30) ,  WJ  (30) ,A11 (3,3,30)  SLIP 

COMMON/ SGMNTS/  D(3,3,30) ,WMEG(3,30) ,WMEGD(3,30) ,U1(3,30) ,U2(3,30) .OUTPUT 

»  SEGLP(3,30) ,SEGL7(3,30) ,SEGLA(3,30) ,NSYM(30)  OUTPUT 

COMMON/ DESORP/  PHK3.30)  ,W(30)  ,RW(30)  ,SR(4,60)  ,HA(3,60)  ,HB(3,60)  ,  SLIP 

*  RPHI (3,30) ,HT(3,3,60) , SPRING(5 ,90) , VISC(7,90) ,  OUTPUT 

*  JNT(30)  ,IPIN(30)  ,ISING(30)  ,  IGLOBOO)  ,J0INTF(30)  OUTPUT 

COMMON/ JBARTZ/  MNPL(  30) ,MNBLT(  8) ,MNSEG(  30) ,MNBAG(  6) ,  OUTPUT 

»  MPL (3 ,5,30) ,MBLT(3 , 5,8) ,MSEG(3 ,5 ,30) ,MBAG(3 , 10,6) ,  OUTPUT 

»  NTPL(  5,30) ,NTBLT(  5,8),NTSEG(  5,30)  OUTPUT 

COMMON/TITLES/  DATE (3) ,C0MENT(40) ,VPSTTL(20) ,BDYTTL(5) ,  OUTPUT 

»  BLTTTL(5,8) ,PLTTL(5,30) ,BAGTTL(5,6) ,SEG(30) ,  OUTPUT 

»  J0INT(30) ,CGS(30) ,JS(30)  OUTPUT 

REAL  DATE , COMENT , VPSTTL , BDYTTL , BLTTTL , PLTTL , BAGTTL , SEQ , JOINT  OUTPUT 

LOGICAL* 1  CGS.JS  OUTPUT 

COMMON/ FORCES /PSF( 7, 70) ,BSF(4,20) ,SSF(10,40) ,BAGSF(3,20) ,  NCFORC 

»  PR JNT (7,30), NPANEL (5) , NPSF . NBST , NSSF , N8GSF  OUTPUT 

COMMON/CNSNTS/  PI .RADIAN, G, THIRD, EPS(24) ,  OUTPUT 

»  UNITL,UNITM,UNITT,GRAVTY(3) ,TWOPI  TWOPI 

COMMON/RSAVE/  XSG(3 , 20 ,3) .DPMI (3 ,3 ,30) ,LPMI (30) ,  ATBIII 

»  NSG(9) ,MSG(20,9) ,MCG,MCGIN(24,5) ,KREF(20,9)  TTHKRE: 

COMMON/ COMAIN/ VAR (240) ,DER(240) ,DT,HO,HMAX,HMIN,RSTIME,  OUTPUT 

»  ISTEP .NSTEPS ,NDINT ,NEQ , IRSIN , IRSOUT  OUTPUT 


OUTPUT 

OUTPUT 

OUTPUT 

OUTPUT 

OUTPUT 

OUTPUT 

OUTPUT 

OUTPUT 

OUTPUT 

OUTPUT 

NCFORC 

OUTPUT 

OUTPUT 

TWOPI 

ATBIII 

TTHKREF 

OUTPUT 

OUTPUT 


COMMON/DAMPER/  APSDM(3,20) ,APSDN(3,20) ,ASD(5,20) ,MSDM(20) ,MSDN (20) OUTPUT 


COMMON/HRNESS/  BAR(15,100) . BB ( 100) .BBDOT(IOO) , PLOSS (2 , 100) , 

*  XL0NG(20) , HTIME(2) , IBAR(5, 100) ,NL(2,100) , 

*  NPTSPB (20) ,NPTPLY(20) ,NTHRNS(20) ,NBLTPH(5) 
COMMON/ WINDFR/  WTIME(30) ,QFU(3,5) ,0FV(3,5) ,WF(3,30) ,IWIND(30) 

*  MWSEG(7 , 30) , NFVSEG(6) ,NFVNT(5) ,M0WSEG(30,30) 
COMMON/TEMP VS/  TDATA(14,65) ,ACC(7,20) ,T1(3) , T2 (3) ,T3(3) ,T4(9) 

*  ,T5(3,3) ,T6(3,3) ,T7(3) 

LOGICAL  LTAPE8  ,  LTHIST 

DATA  LINES/-1/ .LPP/45/ .NTMAX/65/ 

DATA  KMAX/20/ .NMAX/22/ .MCGMAX/5/ 


IF  (IJK.NE.O)  GO  TO  13 


SET  ALL  FORCE  ARRAYS  TO  ZERO. 


OUTPUT 

OUTPUT 

OUTPUT 

WINDOP 

WINDOP 

CHGIII 

CHGIII 

OUTPUT 

CHGIII 

CHGIII 

OUTPUT 

OUTPUT 

OUTPUT 

OUTPUT 

OUTPUT 


iv® 


nwMl 


DO  2  1*1,7  MISDOT 

DO  2  J= 1 ,70  MISDOT 

2  PSF(I.J)  =  0.0  MISDOT 

DO  3  1=1,4  MISDOT 

DO  3  J=1 ,20  MISDOT 

3  BSF(I,J)  =  0.0  MISDOT 

DO  4  1=1,10  MISDOT 

DO  4  J= 1 , 40  MISDOT 

4  SSF(I.J)  =  0.0  MISDOT 

DO  5  1=1,3  MISDOT 

DO  5  J=1 ,20  MISDOT 

5  BAQSF(I ,J)  =0.0  MISDOT 

DO  6  1=1,7  MISDOT 

DO  6  J= 1 ,30  MISDOT 

6  PRJNT(I.J)  =  0.0  MISDOT 

GO  TO  66  OUTPUT 

C  OUTPUT 

C  LTHIST  =  TRUE  MEANS  PRINT  LINE  OF  TIME  HISTORY  DATA  FOR  THIS  OUTPUT 

C  TIME  POINT  ON  EACH  OUTPUT  UNIT  (NT) .  OUTPUT 

C  OUTPUT 

C  LTAPE8  =  TRUE  MEANS  WRITE  TIME  HISTORY  DATA  ON  TAPE  8.  OUTPUT 

C  OUTPUT 

13  NPRT4  =  NPRTC4)  ♦  4  OUTPUT 

IF  (NPRT4.LE.0  .OR.  NPRT4.0T.8)  STOP  37  OUTPUT 

IF(NPRT(26) .EQ.6)  GO  TO  66  TGMDD1 

GO  TO  (66,66,66,15,16,17,17,16)  ,  NPRT4  OUTPUT 

15  LTAPE8  =  .FALSE.  ODTSTP 

LTHIST  =  .TRUE.  TGM0D1 

GO  TO  116  TGM0D1 

16  LTHIST  =  .TRUE.  TGM0D1 

LTAPE8  =  .TRUE.  TGMOD1 

GO  TO  116  TGM0D1 

17  LTHIST  =  .FALSE.  TGM0D1 

LTAPE8  =  .TRUE.  TGMOD1 

GO  TO  217  TGMOD1 

116  TEST  =  D MOD (TIME, DT)  OUTSTP 

TEST  =  DMIN1 (TEST. DABS (DT-TEST))  OUTSTP 

IF  ((NPRT(26) .EQ.0.0R.MPRT(26) .EC. 3) . AMD. TEST. GE.EPS(8))  TGMOD1 

•  LTHIST*. FALSE.  TGMOD1 

I F(. MOT. LTAPE8. AND. .NOT. LTHIST)  GO  TO  66  FIXTTH 

217  CONTINUE  TGM0D1 

IF(NPRT(26) .EQ.4)  LTHIST* . FALSE.  TGMOD1 

IF(NPRT(26) .EQ.5)  LTAPE8= .FALSE.  TGM0D1 

I F(. NOT. LTAPE8. AND. .NOT. LTHIST)  GO  TO  66  TGM0D1 

CALL  ELTIME  (1,8)  OUTPUT 

IF  (LINES. GE.O)  GO  TO  21  FIXTTH 

PREVT  =  -990.0  OUTPUT 

LINES  =  0  FIXTTH 

IF  (IRSIM.HE.O)  GO  TO  10  OUTPUT 

C  OUTPUT 


u  o  u  o  o  u 


c 

C 

C 

C 

C 

C 

C 

C 

C 

r* 

U 

C 

C 

c 


1ST  TIME  IN  ROUTINE,  BEAD  CARD  INPUT  FOR  OUTPUT  CONTROL.  OUTPUT 

OUTPUT 

1.  NO.  OF  POINT  TOTAL  ACCELERATIONS  .POINT  NOS.  AND  LOCATIC’  CHGIII 

2.  NO.  OF  POINT  REL.  VELOCITIES  .POINT  NOS.  AND  LOCATION  CHGIII 

3.  NO.  OF  POINT  REL.  LINEAR  DISPLACEMENTS  .POINT  NOS.  AND  LOCATICHGIII 

4.  NO.  OF  SEGMENT  ANGULAR  ACCELERATIONS  AND  SEGMENT  NOS.  CHGIII 

5.  NO.  OF  SEGMENT  REL.  ANGULAR  VELOCITIES  AND  SEGMENT  NOS.  CHGIII 

6.  NO.  OF  SEGMENT  REL.  ANGULAR  DISPLACEMENTS  AND  SEGMENT  NOS.  CHGIII 

7.  NO.  OF  JOINT  PARAMETERS  AND  JOINT  NOS.  OUTPUT 

8.  BO.  OF  SEGMENT  WIND  FORCES  AND  SEGMENT  NOS.  WINDOP 

9.  NO.  OF  JOINT  FORCES  AND  TORQUE  NOS.  WINDOP 

10.  NO.  OF  CENTER  OF  GRAVITY  AND  RELATED  INFORMATION  WINDOP 

OUTPUT 

WRITE (6. 478)  CHGIII 

478  FORMAT (1X./.2X, ’TABULAR  TIME  HISTORY  CONTROL  PARAMETERS’)  CHGIII 

WRITE(6,479)  CHGIII 

479  FORMAT (3X, ’TYPE  KSG  SELECTED  SEGMENTS  OR  JOINTS’)  TTHKREF 

DO  20  K=1 ,9  WINDOP 

OUTPUT 

INPUT  CARDS  H.(K).(J)  FOB  K*l,3  OUTPUT 

OUTPUT 

IF  (K.LE.3)  JEAD  (5,18)  KSG.KREFO ,K) ,MSG(1 , K) , (XSG(I , 1 ,K) ,1=1,3)  TTHKREF 

18  FORMAT  (16 , 213 , 3F12 .6)  TTHKREF 

IF  (KSG.GT.KMAX)  STOP  84  CHGIII 

IF  (K.GT.3)  GO  TO  201  ATBIII 

IF  (KSG.LE.l)  READ (5, 2 13)  I DUMMY  ATBIII 

213  FORMAT (12)  ATBIII 

IF  (KSG.LE.l)  GO  TO  201  ATBIII 

DO  205  J=2,KSG  ATBIII 

READ  (5,210)  KREF(J.K) ,MSG(J,K) ,(XSG(I,J,K) ,1*1,3)  TTHKREF 

210  FORMAT  (19 , 13 , 3F12 . 6)  TTHKREF 

205  CONTINUE  ATBIII 

201  CONTINUE  ATBIII 

OUTPUT 

INPUT  CARDS  H. (K)  FOR  K=4,9  WINDOP 

OUTPUT 

IF  (K.GT.3)  READ  (5,19)  KSG, (KREF(J.K) ,MSG(J,K) ,J*1 ,KSG)  TTHKREF 

19  F0RMAT(I6, 2213/(19, 2113) )  TTHKREF 

IF  (KSG.GT.KMAX)  STOP  85  CHGIII 

WRITE  (6,78)  K.KSG, (MSG(J.K) ,J=1 ,KSG)  TTHKREF 

WRITE  (8,81)  (KREF(J.K) ,J=1,KSG)  TTHKREF 

78  FORMAT (’  H. ’ ,11 , IX, 13, 3X, 2013)  '  TTHKREF 

81  FORMAT ( ’  REF  ’,2013)  TTHKREF 

DO  80  J=1 ,KSG  TTHKREF 

IF(KREF(J,K) .GT.NGRND.OR.KREF(J.K) .LT.O)  STOP  55  TTHKREF 

80  CONTINUE  TTHKREF 

IF  (K.NE.7  .OR.  KSG.EQ.O)  GO  TO  20  OUTPUT 

DO  12  J=  1 , KSG  OUTPUT 

L  =  MSG(J,K)  OUTPUT 

IF  (IABS(IPIN(L) ) .EQ.4)  MSG(J,K)  =  -L  OUTPUT 


1 

|s 
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12  CONTINUE 

20  NSG(K)  *  KSG 

READ  INPUT  CARDS  H.IO 

READ  (5.111)  MCG 

111  FORMAT (16) 

IF  (MCG.GT.MCGMAX)  STOP  86 
IF  (MCG.EQ.O)  GO  TO  114 
DO  113  K= 1 , MCG 

READ  (5.112)  M.N, (MCGIN(I+2 ,K) ,I*1,N) 

112  FORMAT  (2413) 

IF  (M.GT.NMAX)  STOP  87 

WRITE  (6,117)  N, (MCGIN(I+2,K) ,I=1,N) 

117  FORMAT ( ’  H.IO’ ,13, 3X, 2213) 

WRITE  (6,81)  M 
MCGIN(l.K)  =  M 

113  MCGIN(2.K)  *  N 

114  CONTINUE 

10  IF  ( .N0T.LTAPE8)  GO  TO  21 

WRITE  (8)  NSEG , NJNT , NPL , HBLT , NBAG , NVEH , NGRND , NPANEL , 

»  MNPL , MNBLT , MNSEG , MNBAG , MPL , MBLT , MSEG , MBAG 

WRITE  (8)  DATE , COMENT , 7PSTTL , BDYTTL , BLTTTL , PLTTL , BAGTTL , 

»  SEG, JOINT, UNITL.UHITM.UNITT.NSG, MSG. XSG, MCG, 

*  MCGIN , KREF , NHRNSS , IBLTPB , NPTSPB , NSD , MSDM . MSDN 

21  IF (LTHIST)  LINES5  LIMES  ♦  1 

IF  (MOD (LINES, LPPKEQ.l  .AND.  LTHIST)  CALL  HEDING  (LINES, LPP) 
NT  5  20 

USEC  =  1000 . 0»TIME 

COMPUTE  AND  PRINT  DATA  FOR  9  TYPES  OF  OUTPUT  ABOVE 
DO  44  K= 1 ,9 

IF  (NSG(K) .LE.O)  GO  TO  44 
KSG  5  NSG(K) 

IF  (K.GT.8)  GO  TO  440 
J3  5  3 

IF  (K.EQ.7)  J3  5  2 
DO  43  Jl=l , KSG, J3 
J2  5  MIM0(J1+J3-1 ,KSG) 

NT  =NT  ♦  1 

SETUP  LOGICAL  UNIT  CONTROL  (FOR  PRINTER)  FOR  PERKIN  &  ELMER 
CALL  CARCON(NT.l) 

DO  38  J*J1,J2 
L  5  IABS (MSG(J ,K) ) 

GOTO  (22,24,26,29,31,34,35,601) ,K 

1.  POINT  TOTAL  ACCELERATION  IN  KREF(l)  REFERENCE 

22  IF(LPMI(L) .EQ.O)  GO  TO  521 
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CALL  MAT31 (DPMI ( 1 , 1 ,L) ,XSG( 1 , J ,K) ,T7)  CHQIII 

00  TO  523  CHQIII 

521  DO  522  JL*1 ,3  CHQIII 

522  T7(JL)  =  XSQ(JL, J,K)  CHQIII 

523  CALL  CBOSS  (WMEG(1 ,L) ,T7 ,T1)  CHQIII 

CALL  CROSS  (WMEG(1,L)  ,T1,T2)  OUTPUT 

CALL  CBOSS  (WMEGD(l.L) ,T7,T3)  CHQIII 

CALL  HAT31(D(ltl.L) ,GRAVTYtT7)  ACCEL 

CALL  MAT31 ( D ( 1 , 1 , L ) , SEQLA( I , L) ,T4)  OUTPUT 

DO  23  1=1,3  OUTPUT 

IF(ICG(J,K) .LT.O)  T4 (I) =T4 (I) +T7 (I)  ,  ACCEL 

ACC (I , J)  =  (T4 (I) +T3 (I) +T2 (I) ) /G  OUTPUT 

23  T1(I)  =  ACC (I , J)  OUTPUT 

IF(MSQ(J,K) .QE.O)  GO  TO  405  ACCEL 

KBF=L  ACCEL 

IF(LPMI (KRF) .NE.O)  CALL  D0T31 (DPMI ( 1 , 1 ,KRF) ,T1 , ACC ( 1 ,J) )  ACCEL 

IF(KBEF(J,K) . EQ . 1 }  GOTO  33  ACCEL 

DO  600  11=1,3  ACCEL 

600  ACC (II , J) =ACC(II , J) -GBAVTY(II) /G  ACCEL 

GOTO  33  ACCEL 

OUTPUT 

2.  POINT  REL.  TELOCITY  IN  KREF(2)  REFERENCE  CHQIII 

OUTPUT 

24  IF(KREF(J,2) .EQ.O)  KRF  =  NVEH  TTHKREF 

IF(KREF(J,2) .NE.O)  KRF  =  KREF(J,2)  TTHKREF 

IF(LPMI(L) .EQ.O)  GO  TO  524  CHGIII 

CALL  MAT31 (DPMI (1,1 ,L) ,XSG(1 , J,K) ,T7)  CHQIII 

GO  TO  525  CHGIII 

524  DO  526  JL=1,3  CHGIII 

526  T7(JL)  =  XSG(JL, J,K)  CHGIII 

525  CALL  CROSS  (WMEGd  ,L)  ,T7,T1)  CHGIII 

CALL  D0T31(D( 1,1, L) ,T1,T2)  OUTPUT 

DO  25  1=1,3  OUTPUT 

25  T3(I)  =  T2(I)  ♦  SEGLV(I , L)  -  SEGLT(I ,KRF)  CHGIII 

GO  TO  28  OUTPUT 

OUTPUT 

3.  POINT  REL.  LINEAR  DISPLACEMENT  IN  KBEF(3)  REFERENCE  CHQIII 

OUTPUT 

26  IF(KREF(J,3) .EQ.O)  KRF  =  NVEH  TTHKREF 

IF(KREF(J,3) .NE.O)  KRF  =  KREF(J,3)  TTHKREF 

IF  (LPMI(L) .EQ.O)  GO  TO  76  CHGIII 

CALL  D0T33  (DPMI (1 , 1 ,L) ,D(1 , 1 ,L) ,T4)  OUTPUT 

CALL  D0T31  (T4 ,XSG( 1 , J,K)  , T 1 )  OUTPUT 

GO  TO  77  OUTPUT 

76  CALL  D0T31  (D ( 1 , 1 ,L) ,XSG(1 , J.K) ,T1)  OUTPUT 

77  DO  27  1=1,3  OUTPUT 

27  T3(I)  =  T1(I)  +  SEGLP(I.L)  -  SEGLP(I.KRF)  CHGIII 

28  IF  (LPMI (KRF) .EQ.O)  GO  TO  403  CHGIII 

CALL  D0T33(DPMI (1,1 ,KRF) ,D(1 , 1 ,KRF) ,T5)  CHGIII 

CALL  MAT31 (T5 ,T3 , ACC (1 , J) )  CHGIII 


o  o  o  nan 


GO  TO  33 

OUTPUT 

403 

CALL  MAT31 (D( 1 , 1 , KRF) ,T3, ACC ( 1 , J) ) 

CHGIII 

33 

ACC ( 4 , J )  =  DSQRT (ACC ( 1 , J) *»2+ACC (2 , J) *»2+ACC (3 , J) »»2) 

CHGIII 

GO  TO  38 

CHGIII 

c 

OUTPUT 

c 

4.  SEGMENT  ANGULAR  ACCELERATION  IN  KREF(4)  REFERENCE 

CHGIII 

c 

OUTPUT 

29 

DO  30  1=1,3 

OUTPUT 

ACC(I.J)  =  WMEGD(I ,L)/(2.0»PI) 

OUTPUT 

30 

T1(I)  =  ACC (I , J) 

OUTPUT 

405 

CONTINUE 

CHGIII 

IF(KREF(J,K) .EQ.O)  GO  TO  401 

TTHXREF 

KRF  =  KREF(J.K) 

TTHKREF 

IF(LPMI (KRF) .EQ.O)  GO  TO  402 

CHGIII 

CALL  DOT33 (DPMI (1,1, KRF) ,D(1,1,KRF) ,T5) 

CHGIII 

CALL  DOTT33 (T5 ,D( 1 , 1 ,L) ,T6) 

CHGIII 

CALL  MAT31 (T6 ,T1 , ACC ( 1 , J) ) 

CHGIII 

GO  TO  33 

CHGIII 

402 

CALL  DOTT33(D(l , 1 ,KRF) ,D(1,1,L) ,T6) 

CHGIII 

CALL  MAT31 (T6 ,T1 , ACC ( 1 , J) ) 

CHGIII 

GO  TO  33 

CHGIII 

401 

KRF  =  L 

CHGIII 

IF (LPMI (KRF) .NE.O)  CALL  DOT31 (DPMI ( 1 , 1 ,KRF) ,T1 , ACC ( 1 ,J) ) 

CHGIII 

GO  TO  33 

OUTPUT 

c 

OUTPUT 

c 

5.  SEGMENT  REL.  ANGULAR  VELOCITY  IN  KREF(5)  REFERENCE 

CHGIII 

c 

OUTPUT 

31 

IF(KREF(J,5) .EQ.O)  KRF  *  NVEH 

TTHKREF 

IF(KREF(J,5) .NE.O)  KRF  =  KREF(J,5) 

TTHKREF 

CALL  DOT31  (D ( 1 , 1 ,L) ,WMEG(1 ,L) ,T1) 

CHGIII 

CALL  MAT31  (D ( 1 , 1 .KRF) ,T1 ,T2) 

CHGIII 

DO  32  I=l,o 

OUTPUT 

IF  (KRF.NE.L)  T2 (I) =T2 (I) -WMEG(I ,KRF) 

PLTINC 

32 

T3 (I)  =  T2 (I) / (2 . 0*PI ) 

PLTINC 

IF(LPMI (KRF) .EQ.O)  GO  TO  449 

CHGIII 

CALL  D0T31 (DPMI (1,1, KRF) ,T3 , ACC ( 1 , J) ) 

CHGIII 

GO  TO  483 

CHGIII 

449 

CONTINUE 

CHGIII 

DO  457  KJL= 1 ,3 

CHGIII 

457 

ACC(KJL.J)  =  T3 (KJL) 

CHGIII 

483 

ACC (4 , J)  =  DSQRT (ACC ( 1 , J) »«2+ACC (2 , J) »«2+ACC (3 , J) **2) 

CHGIII 

GO  TO  38 

OUTPUT 

c 

OUTPUT 

c 

6.  SEGMENT  REL.  ANGULAR  DISPLACEMENT  IN  KREF(6)  REFERENCE 

CHGIII 

c 

OUTPUT 

34 

IF(KREF(J,6) .EQ.O)  KRF  =  NVEH 

TTHKREF 

IF(KREF(J,6) .NE.O)  KRF  =  KREF(J,6) 

TTHKREF 

IF  (LPMI (KRF) .EQ.O. AND. LPMI (L) .EQ.O)  GO  TO  38 

CHGIII 

IF  (LPMI (L) .EQ.O)  GO  TO  435 

CHGIII 

CALL  D0T33 (DPMI ( 1 , 1 , L) ,D(1,1,L) ,T4) 

CHGIII 

«'»V,L 
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.ViV 

$ 

,i*W 
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IF  (LPMI(KRF)  .EQ.O)  00  TO  430 

CALL  D0T33 (DPMI (1,1 ,KRF) .D(l.l.KBF) ,T5) 

IF  (LPlfl  (L)  . NE.O)  GO  TO  438 
CALL  D0TT33 (0(1,1, L) ,T5,T1) 

GO  TO  37 

IF  (LPMI (KRF) .ME.O)  GO  TO  439 
CALL  D0TT33 (T4 ,D(1 , 1 ,XBF) ,T1) 

GO  TO  37 

CALL  D0TT33 (T4 , T5 , T 1 ) 

GO  TO  37 

CALL  D0TT33(D(1 , 1 ,L) ,D(1.1,KRF) ,T1) 

CALL  YPRDEG(T1 , ACC ( 1 , J) ) 

TRACE  =  0 . 5» (T1 ( 1) +T2 (2) +T3 (3) -1.0) 

IF  (TRACE. GT.  1.0)  TRACE  =  1.0 

IF  (TRACE.LT. -1.0)  TRACE  =  -1.0 
ACC ( 4  ,  J )  =  DACOS (TRACE) /RADI AM 
GO  TO  38 

7.  JOINT  PARAMETERS 

ACC(l.J)  =  PRJNT(l.L) 

ACC  (2  ,  J)  =  PRJNT (2 ,L) /RADIAN 
ACC (3 ,  J)  =  P RJNT (3, L) /RADIAN 
ACC ( 4  ,  J)  =  PRJNT ( 4, L) /RADI AM 
ACC (5 , J)  =  DSQRT(PRJNT(5,L) ) 

ACC (6 ,  J)  =  DSQRT (PRJNT (0,L)) 

ACC (7 , J)  *  DSQRT (PRJNT (7, L) ) 

GOTO  38 

8.  SEGMENT  WIND  FORCE  IN  KREF(8)  REFERENCE 

IF(KREF(J,8) .EQ.O)  KRF  =  NGRMD 
IF(KREF(J,8) .NE.O)  KRF  =  KREF(J,8) 

CALL  MAT31  (D ( 1 , 1 .KRF) ,WF(1 ,L) ,T2) 

IF(LPMI (KRF) .EQ.O)  GO  TO  602 

CALL  D0T31 (DPMI (1,1, KRF) ,T2 , ACC ( 1 , J) ) 

GO  TO  604 
CONTINUE 
DO  603  KJL= 1 , 3 
ACC(KJL.J)  =  T2 (KJL) 

ACC ( 4 , J )  =  DSQRT (ACC ( I , J) *»2+ACC (2 , J) »»2*ACC (3 , J) »»2) 
CONTINUE 

IF  ( .N0T.LTAPE8)  GO  TO  40 
KK  =  0 
12  =  4 

IF  (K.EQ.7)  12  =  7 

DO  39  J=J1 , J2 
DO  39  1=1,12 

KK  =  KK+1 

TDATA(KK ,NT-20)  =  ACC(I.J) 
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40  I*  * . NOT .LTHIST)  GO  TO  43 

IF  (K.LE.6)  WRITE  (HT.41)  USEC , { (ACC (I , J) , 1= 1 , 4) , J=J1 , J2) 

IF  (K.EQ.8)  WRITE  (NT, 41)  OSEC , ( (ACC (I , J) , 1= 1 , 4) , J=J1 , J2) 

41  F0RMAT(F9.3,3(3X,4F9.3)  ) 

IF  (K.EQ.7)  WRITE  (NT, 42)  OSEC, ( (ACC(I ,J) ,1=1 ,7) , J=J1 ,J2) 

42  FORMAT (F9 . 3 , 2 (F5 . 0 , 3F9 . 3 , 2X , 3F9 . 3) ) 

43  CONTINUE 
GO  TO  44 

9.  JOINT  FORCES  &  TORQUES  IN  KREF(9)  GEOMETRIC  COORDINATE  SYSTEM 

140  DO  860  L=1,KSG 
KRF  =  NVEH 

IF(KREF(L,9) .NE.O)  KRF  =  KREF(L,9) 

LL=MSG(L,K) 

IF  (LPMI(KRF) .EQ.O)  GO  TO  851 

CALL  D0T33  (DPMI (1,1 ,KRF) ,D{ 1 , 1 ,KRF) ,T5) 

CALL  MAT31  (T5,F(1 ,LL) . T 1 ) 

CALL  MAT31  (T5,TQ(1 ,LL) ,T2) 

DO  852  JJ= 1 , 3 
Tl(JJ)  =  T1 ( JJ) / 100 . 0 

352  T2 ( JJ)  =  -T2 (JJ) / 100 . 0 
GO  TO  859 

151  CONTINUE 

CALL  MAT31  (D ( 1 , 1 ,KRF) , F ( 1 , LL) ,T1) 

CALL  MAT31  (D( 1 , 1 ,KRF) ,TQ( 1 ,LL) ,T2) 

DO  853  JJ= 1 , 3 
Tl(JJ)  =  T1 ( JJ) / 100 . 0 

353  TK (JJ)  =  -T2(JJ)/ 100.0 
159  NT  =  NT  ♦  1 

P  &  E  CARRIAGE  CONTROL 
CALL  CARCON(NT.l) 

IF  ( .N0T.LTAPE8)  GO  TO  855 

DO  854  JL= 1 , 3 

TDATA  (JL  .NT-20)  =  T1 (JL) 

354  TDATA  (JL+3, NT-20)  =  T2(JL) 

355  CONTINUE 

IF  (LTHIST)  WRITE  (NT, 857)  USEC,T1,T2 
357  FORMAT (F9 . 3 ,3X ,3F9 . 3 , 3X , 3 (2X , DIO . 3) ) 

360  CONTINUE 

44  CONTINUE 

10.  PRINT  BODY  PROPERTIES 

IF  (MCG.EQ.O)  GO  TO  131 
DO  130  NCG=1,MCG 
M  =  MCGIN ( 1 , NCG) 

N  =  MCGIN (2, NCG) 

DO  120  J= 1 , 9 
120  T4 ( J)  =  0.0 
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SUMW  =  0.0 
T7(  1) =0.0 
T7 (2) =0 . 0 
DO  123  1=1, M 
K  =  MCGIN(I+2,NCG) 

WG  =  W(K)/G 

V= ( SEQLV (1 , K ) - SEGLV ( 1 , M) ) *  *  2 
«  +(SEGLV(2,K)-SEGLV(2,M))«*2 
«  +(SEGLV(3,K)-SEGLV(3,M))»*2 
T7 ( 1) =T7 ( 1) +0 . 5»WG*V 
SUMW  =  SUMW  ♦  WG 
DO  121  J= 1 ,3 

T7 (2) =T7 (2) +0. 5»PHI (J ,K) * (WMEG(J ,K) -WMEG(J ,M) ) »*2 

121  T1(J)  =  PHI (J ,K) »WMEG( J ,K) 

CALL  DOT31  (D(l.l.X) ,T1,T2) 

CALL  CROSS  (SEGLP(1 ,K) , SEGLV (1 ,K) , T 1 ) 

DO  122  J=1 ,3 

T4 ( J  )  =  T4(J  )  ♦  WG*SEGLP( J ,K) 

T4 (J+3)  =  T4 (J+3)  +  WG»SEGLV(J,K) 

122  T4 (J+6)  =  T4 (J+6)  +  WG*T1(J)  ♦  T2(J) 

123  CONTINUE 

T7 (3) =T7( 1) +T7 (2) 

DO  124  J=1 ,3 

124  T4 ( J)  =  T4(J)/SUMW  -  SEGLP(J.M) 

TRANSFORM  FROM  PRINCIPAL  AXES  TO  LOCAL  AXES 

IF  (LPMI(M) .EQ.O)  GO  TO  330 

CALL  DOT33 (DPMI (1,1, M)  ,D(1,1,M) ,T5) 

CALL  MAT31 (T5 ,T4 ( 1 ) ,T1) 

CALL  MAT31 (T5 ,T4 (4) ,T2) 

CALL  MAT31 (T5 ,T4 (7) ,T3) 

GO  TO  333 
330  CONTINUE 

CALL  MAT31  (D ( 1 , 1 ,M) ,T4(1) ,T1) 

CALL  MAT31  (D ( 1 , 1 ,M) ,T4 (4) ,T2) 

CALL  MAT31  (D ( 1 , 1 ,M) ,T4 (7) ,T3) 

333  CONTINUE 
NT  =  NT  +  1 

IF  ( . NOT . LTAPE8)  GO  TO  126 
DO  125  J=1 ,3 

TDATA  (J  , NT-20)  =  T1(J) 

TDATA  (J+3, NT-20)  =  T2(J) 

TDATA(J+9, NT-20)  =  T7(J) 

125  TDATA(J+6, NT-20)  =  T3(J) 

126  IF  (LTHIST)  WRITE  (NT, 127)  USEC ,T1 ,T2 ,T3 ,T7 

127  FORMAT  (F9 . 3 , 3F8 . 3 ,9 ( IX, DIO. 3) ) 

130  CONTINUE 

131  CONTINUE 
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PRINT  PLANE  FORCES  OUTPUT 

OUTPUT 

MPSF  =  0  OUTPUT 

IF  (NPL.EQ.O)  GO  TO  49  OUTPUT 

IF  (NPRT(18) . EQ. 1 .OR.NPRT ( 18) . EQ.7)  GO  TO  49  VARTTH 

IF  (NPRT(I8) .EQ. 10. OR.NPRT (18) .EQ. 11)  GO  TO  49  VARTTH 

IF  (NPRT(18) .GE. 14)  GO  TO  49  VARTTH 

DO  45  J=1 ,NPL  OUTPUT 

45  MPSF  =  MPSF  ♦  MNPL(J)  OUTPUT 

IF  (MPSF.EQ.O)  GO  TO  49  OUTPUT 

DO  47  J 1 = 1 , MPSF, 2  OUTPUT 

J2  =  MIN0(J1+1,MPSF)  OUTPUT 

NT  =  NT+1  OUTPUT 

SETUP  LOGICAL  UNIT  CONTROL  (PRINTER  CONTROL)  FOR  P  &  E  PECONV 

CALL  CARCON(NT.l)  PECONV 

IF  (.N0T.LTAPE8)  GO  TO  47  OUTPUT 

KK  =  0  OUTPUT 

DO  46  J=J1,J2  OUTPUT 

DO  46  1=1,7  OUTPUT 

KK  =  KK+1  OUTPUT 

46  TDATA(KK ,NT-20)  =  PSF(I.J)  OUTPUT 

47  IF  (LTHIST)  WRITE  (NT, 48)  USEC , ( (PSF (I , J) , 1=1 , 7) , J=J1 , J2)  OUTPUT 

48  FORMAT (F9 .3,2 (F9 . 3 , 3F9 . 2 , 3F8 .3)  )  OUTPUT 

OUTPUT 

PRINT  BELT  FORCES  OUTPUT 

OUTPUT 

49  MBSF  =  0  OUTPUT 

IF  (NBLT.EQ. 0)  GO  TO  67  OUTPUT 

IF  (NPRT(18) . EQ. 2 . OR. NPRT ( 18) .GE. 13)  GO  TO  67  VARTTH 

IF  (NPRT(18)  .GE.7.AND.NPRTU8)  .LE.9)  GO  TO  67  VARTTH 

DO  50  J= 1 , NBLT  OUTPUT 

50  MBSF  =  MBSF  +  MNBLT(J)  OUTPUT 

IF  (MBSF.EQ.O)  GO  TO  67  OUTPUT 

DO  52  «J  1  =  1 , MBSF, 2  OUTPUT 

J2  =  MIN0(J1+1 .MBSF)  OUTPUT 

NT  =  NT*1  OUTPUT 

LOGICAL  UNIT  (PRINTER  CONTROL)  FOB  P  &  E  PECONV 

CALL  CABCON(NT.l)  PECONV 

IF  ( . NOT. LT APES)  GO  TO  52  OUTPUT 

KK  =  0  OUTPUT 

DO  51  J=J1,J2  OUTPUT 

DO  51  1=1,4  OUTPUT 

KK  =  KK* 1  OUTPUT 

51  TDATA1KK, NT-20)  =  BSF(I,J)  OUTPUT 

52  IF  (LTHIST)  WRITE  (NT, 53)  USEC , ( (BSF(I , J) , 1=1 ,4) , J=J1 , J2)  OUTPUT 

53  FORMAT (F9.3,4 (F15.6  F12 . 2 ,3X)  )  OUTPUT 

OUTPUT 

PRINT  HARNESS-BELT  ENDPOINT  FORCES  (STORED  IN  BSF  ARRAY) .  OUTPUT 

OUTPUT 

67  IF  (NHRNSS.LE.O)  GO  TO  71  OUTPUT 
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IF  (NPRT (18) .EQ. 3. OB. NPRT (10) . EQ. 11)  00  TO  71 
IF  (NPRT(18) . EQ. 9 . OR. NPBT( 18) .EQ.8)  00  TO  71 
IF  (NPRT(18).EQ.1J.0B.NPRT(18).EQ.14)  00  TO  71 
IF  (MPBT(18) .0E.16)  GO  TO  71 
MBSFl  =  MBSF  +  1 
DO  68  1  =  1 , NHRNSS 

68  MBSF  =  MBSF  +  NBLTPH(I) 

DO  70  J 1 =MBSF 1 , MBSF , 2 
J2  =  MIN0(J1+1 , MBSF) 

NT  =  HT+1 

LOGICAL  UNIT  (PBINTEB  CONTBOL)  FOB  P  &  E 
CALL  CABCON(NT, 1) 

IF  ( .NOT. LT APES)  00  TO  70 
KK  =  0 

DO  69  J=J1 , J2 
DO  69  1=1,4 

KK  =  KK* 1 

69  TDATA(KK,NT-20)  =  BSF(I.J) 

70  IF  (LTHIST)  WBITE  (NT, 53)  USEC, ( (BSF(I , J) ,1=1 ,4)  ,J=J1 ,J2) 
PRINT  SPRING  DAMPER  FORCES  (STORED  IN  BSF  ARRAY) . 

71  IF  (NSD.LE.O)  00  TO  54 

IF  (NPRT(18) . EQ. 4 . OR. NPRT ( 18) . EQ.9)  GO  TO  54 

IF  (NPRT (18) .0E.12)  GO  TO  54 

MBSFl  =  MBSF  +  1 

MBSF  =  MBSF  +  (NSD+D/2 

DO  73  J 1 =MBSF 1 , MBSF , 2 

J2  =  MIN0(J1+1 ,MBSF) 

NT  =  NT* 1 

LOGICAL  UNIT  (PRINTER  CONTBOL)  FOB  P  &  E 
CALL  CARCON(NT.l) 

IF  ( .N0T.LTAPE8)  00  TO  73 
KK  =  0 

DO  72  J=J1,J2 

DO  72  1=1,4 

KK  =  KK+1 

72  TDATA(KK, NT-20)  =  BSF(I,J) 

73  IF  (LTHIST)  WRITE  (NT, 74)  USEC, ( (BSF (I ,J) ,1=1 ,4) ,J=J1 ,J2) 

74  FORMAT  (F9.3.4 (F14.3.F12. 2 ,4X) ) 

PRINT  SEGMENT  CONTACT  FORCES 

54  MSSF  =  0 

IF  (NPRT  (18)  .EQ.5.0R.NPRTU8)  .EQ.  13)  GOTO  161 
IF  (NPRT (18) .EQ. 10 .OR. NPRT ( 18) .EQ. 11)  GOTO  161 
IF  (NPRT(18) .GE.15)  GOTO  161 
DO  55  J= 1 , NSEG 

55  MSSF  =  MSSF  *  MNSEG(J) 

IF  (MSSF.EQ.O)  GO  TO  59 
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DO  57  J-l ,MSSF 
NT  =  NT+1 

LOGICAL  UNIT  (PBINTEB  CONTBOL)  FOB  P  &  E 
CALL  CABCON (NT , I) 

IF  ( . NOT.LTAPE8)  GO  TO  57 
DO  56  1=1,10 

56  TDATA(I ,NT-20)  =  SSF(I,J) 

57  IF  (LTHIST)  WBITE  (NT, 58)  DSEC . (SSF(I , J) , 1= I , 10) 

58  FOBIIAT  (2F9 . 3 , 3F0 . 2 , 3F8 . 3 , 2X ,  3F8 . 3) 

161  CONTINUE 

PBINT  AIBBAG  FOBCES 

59  IF  (NBAG.EQ.O)  GO  TO  65 
IF  (NPBT(18) .EQ.6.0B.NFBT(18) .EQ.9)  GO  TO  65 
IF  (NPBT( 18) .GE. 12)  GO  TO  65 
K1  =  1 

DO  64  J= 1 , NBAG 
IF  (MNBAG(J) . EQ.O)  GO  TO  64 
KBAG  =  MNBAG ( J ) +NPANEL ( J )  ♦  5 
DO  63  J 1 = 1 , KBAG , 4 
J2  =  KINO (Jl+3 ,KBAG) 

K2  =  K1+J2-J1 
NT  =  NT* 1 

LOGICAL  UNIT  (PBINTEB  CONTBOL)  FOB  P  &  E 
CALL  CABCON (NT, 1) 

IF  ( .NOT. LT APES)  00  TO  61 
KK  =  0 

DO  60  K=K1 ,K2 
DO  60  1=1,3 

KK  =  KK+1 

60  TDATA(KK ,HT-20)  =  BAGSF(I.K) 

61  IF  (.NOT. LTHIST)  GO  TO  63 

IF  (Jl.EQ.l)  WBITE  (NT, 75)  USEC, ( (BAGSF(I ,K) ,1=1 ,3) ,K=K1 ,K2) 
IF  (Jl.NE.l)  WBITE  (NT. 62)  DSEC, ( (BAGSF(I ,K) ,1*1 ,3) ,K*K1 ,K2) 
75  FOBIIAT  (F9 . 3 ,3X, 3F9 . 2 , 2  (3X, 3F9 . 3)  , 3K.3F9 . 2) 

62  F0BMAT(F9.3,4(3X,3F9.2) ) 

63  K1  =  K2+ 1 

64  CONTINUE 

65  NT  =  NT-20 
IF(NT.GT.HTMAX)  STOP  56 

IF  (LTAPE8)  WBITE  (8)  NT, USEC, ( (TDATA(I , J) ,1=1,14) ,J=1 ,NT) 
PBEVT  =  TIME 
CALL  ELTIME(2,8) 

66  BETUBN 
END 
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SUBROUTINE  PANEL  (DRR.ZR.JB)  PANEL 

C  REV  I I I. 2  08/08/84REVI I I 

C  COMPUTES  AIRBAG  PARAMETERS  DURING  INFLATION  OF  BAG.  PANEL 

C  PANEL 

C  GIVEN:  DRR  -  DC  MATRIX  RELATIVE  TO  VEHICLE  PANEL 

C  ZR  -  CG  LOCATION  IN  VEHICLE  REFERENCE  PANEL 

C  PANEL 

C  COMPUTE:  SEGLP , SEGLV , SEGLA , D , WMEG  &  WMEGD  FOR  SEGMENT  JB.  PANEL 

C  PANEL 

IMPLICIT  REAL* 8  (A-H.O-Z)  PANEL 

DIMENSION  DRR(3,3) ,ZR(3) , T 1 ( 3 ) ,T2(3)  PANEL 

COMMON/CONTRL/  T I ME , NSEG , NJNT , NPL , NBLT , NBAG , NVEH , NGRND ,  PANEL 

«  NS , NQ , NSD , NFLX , NHRNSS , NWINDF , NJNTF , NPRT ( 36 ) , NPG  PAGE 

COMMON/ SGMNTS/  D(3,3,30) ,WMEG(3,30) ,WMEGD(3,30) .UK3.30) ,U2(3,30) .PANEL 
*  SEGLP (3, 30) .SEGLV (3, 30) .SEGLA (3,30) ,NSYM(30)  PANEL 

CALL  MAT33  (DRR. D(1 . 1 .NVEH) ,D(1 . 1 ,JB) )  PANEL 

CALL  MAT31  (DRR, WMEG( I .NVEH) ,WMEG( 1 , JB) )  PANEL 

CALL  D0T31  (D ( 1 . 1 , NVEH) , ZR . SEGLP ( 1 , JB) )  PANEL 

CALL  CROSS  (WMEG(l.NVEH) .ZR.Tl)  PANEL 

CALL  DOT31  (D ( 1 . 1 .NVEH) ,T1 ,SEGLV( 1 , JB) )  PANEL 

CALL  CROSS  (WMEG(l.NVEH) .T1.T2)  PANEL 

CALL  D0T31  (D ( 1 , 1 , NVEH) . T2 . SEGLA ( 2 , JB) )  PANEL 

DO  10  1=1,3  PANEL 

SEGLP ( I , JB)  =  SEGLP (I ,JB)  ♦  SEGLP ( I , NVEH)  PANEL 

SEGLV ( I , JB)  =  SEGLV (I , JB)  ♦  SEGLV (I .NVEH)  PANEL 

SEGLA  (I ,  JB)  =  SEGLA  (I ,  JB)  +  SEGLAU  ,NVEH)  PANEL 

10  WMEGD ( I , JB)  =  WMEGD(I.NVEH)  PANEL 

RETURN  PANEL 

END  PANEL 
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SUBROUTINE  PDAUX  ( VAR , DER , NEQ , KO I NT ) 


REV  IV 


PDAUX 

07/24/86SLIP 
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PURPOSE  IS  TO  ACT  AS  INTERFACE  BETWEEN  INTEGRATOR  AND  DAUX  TO 
ACCOMODATE  VARIABLE  NUMBER  OF  FUNCTIONS  TO  BE  INTEGRATED. 

ARGUMENTS : 

VAR  -  ARRAY  OF  NEQ  STATE  VARIABLES  UPDATED  BY  DINT. 

DER  -  ARRAY  OF  NEQ  DERIVATIVES  TO  BE  SUPPLIED  BY  DAUX. 

NEQ  -  NUMBER  OF  STATE  VARIABLES  AND  DERIVATIVES. 

KDINT  -  INTEGRATION  STEP  NUMBER  IN  DINT. 

IMPLICIT  REAL » 8  (A-H.O-Z) 

DIMENSION  VAR(3 , 1) , DER(3 , 1) 

COMMON/ CONTRL/  TIME , NSEG , NJNT , NPL , NBLT , NBAG , NVEH , NGRND , 

*  NS , NQ , NSD , NFLX , NHRNSS , NWINDF , NJNTF , NPRT ( 36 ) ,NPG 
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COMMON/ SGMNTS/  D(3.3.30) ,WMEG(3,30) ,WMEGD(3,30) ,U1(3,30) ,U2(3,30) .PDAUX 

*  SEGLP(3,30) ,SEGLV(3,30) ,SEGLA(3,30) ,NSYM(30)  PDAUX 

COMMON/DESCRP/  PHK3.30)  ,W(30)  ,RW(30)  ,SR(4,60)  ,HA(3,60)  ,HB(3,60)  ,  SLIP 

«  RPHI (3,30) ,HT(3, 3,80) ,SPBING(5, 90) ,VISC(7,90) .  PDAUX 

»  JNT(30) ,IPIN(30) ,ISING(30) ,IGLOB(30) ,J0INTF(30)  PDAUX 

COMMON/TITLES/  DATE(3) ,C0MENT(40) ,VPSTTL(20) ,BDYTTL(5) ,  PDAUX 

*  BLTTTL(5,8) ,PLTTL(5,30) , BAGTTL(5,6) ,SEG(30) ,  PDAUX 

»  JOINT (30) ,CGS(30) ,JS(30)  PDAUX 

REAL  DATE , COMENT , VPSTTL , BDYTTL , BLTTTL , PLTTL , BAGTTL , SEG , JOINT  PDAUX 

LOGICAL* 1  CGS.JS  PDAUX 

COMMON/ INTEST/  SGTEST(3,4.30) ,XTEST(3 , 120) ,SEGT(120) , REGT(120)  PDAUX 
REAL  SEGT  PDAUX 

COMMON/FLXBLE/  HF (4 , 12 ,8) ,B42 (3 .3 ,24) ,V4 (3 ,8) ,NFLEX(3 .8)  PDAUX 

COMMON/CEULER/  IEULER(30) ,HIR(3,3,90) ,ANG(3,30) ,ANGD(3,30) ,  SLIP 

*  FE(3,30) ,TQE(3,30) ,C0NST(5,30)  SLIP 

COMMON/TEMPVS/  T(3,30) ,VXT(3)  PDAUX 

DIMENSION  SD(3,3,30)  ,  El (30)  ,  HTST(30)  ,  LSEG(30)  ,  RGTTL(4)  PDAUX 
LOGICAL  LSEG  PDAUX 

DATA  NTST/30*0/  PDAUX 

DATA  RGTTL/8HANG  VEL  .8HLIN  VEL  , 8HANG  ACC  , 8HLIN  ACC  /  PDAUX 

CALL  ELTIMEU.6)  PDAUX 

MBAG  =  NGRND  PDAUX 

IF  (NTST(l) . NE.O)  GO  TO  10  PDAUX 

LSEG(l)  =  .FALSE.  VAXCHG 

NTST(l)  =  1  ATBIII 

DO  5  M=  2 , MBAG  ATBIII 

LSEG(M)  =  ISING(M) . QE.O  .AND.  JNT(M-i) .NE.O  ATBIII 

IF  (IABS(IPIN(M-1) ) . GE.5. AND. IEULER(M-l) . GE.O)  LSEG (M) > .FALSE.  SLIP 

5  NTST(M)  =  M  PDAUX 

NTST( NGRND)  =  -NGRND  PDAUX 

LSEG (NGRND)  =  .TRUE.  PDAUX 

IF  (NFLX.EQ.O)  GO  TO  10  PDAUX 

DO  6  J= 1 , NFLX  PDAUX 

M  =  NFLEX(2 , J)  PDAUX 

6  NTST(M)  =  -M  PDAUX 
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10  IF  (KDINT.EQ.4)  GO  TO  48 
IF  (KDINT.GT.O)  GO  TO  20 

KDIMT-0  IMPLIES  INITIAL  CALL  FROM  DINT.  PDAUX  TO  SUPPLY  INITIAL 
VALUES  TO  STATE  VABIABLES  AND  COMPUTE  VALUE  OF  NEQ. 


(A)  SET  Q  TO  IDENTITY  QUATERNION 
N  =  0 

DO  12  M= 1 . MBAG 
IF  (NTST(M) .LT.O)  GO  TO  12 
N  =  N+l 

REGT(N)  =  RGTTL(l) 

SEGT(N)  *  SEG(M) 

E1(N)  =  1.0 
DO  11  1=1,3 

XTEST(I.N)  =  SGTESTII , 1 ,M) *»2 

11  VAR(I.N)  =  0.0 

12  CONTINUE 

(B)  SEGLP  OF  REFERENCE  SEGMENTS 

DO  14  M= 1 , MBAG 
IF  (LSEG(Ml)  GO  TO  14 
N  =  N+l 

REGT(N)  =  RGTTL ( 2 ) 

SEGT(N)  =  SEG(M) 

DO  13  1=1,3 

XTEST(I.N)  =  SGTESTII ,2 ,M) **2 

13  VAR(I,N)  =  SEGLP (I ,M) 

14  CONTINUE 

(C)  WMEG 

DO  16  M= 1 , MBAG 
IF  (NTST(M) .LT.O)  GO  TO  16 
N  =  N+l 

REGT(N)  =  RGTTL (3) 

SEGT(N)  =  SEG(M) 

DO  15  1=1,3 

XTEST(I.N)  =  SGTESTII ,3,M) **2 

15  VAR(I.N)  =  WMEG(I.M) 

16  CONTINUE 

(D)  SEGLV  OF  REFERENCE  SEGMENTS 

DO  18  M= 1 , MBAG 
IF  (LSEG(M) )  GO  TO  18 
N  =  N+l 


PDAUX 

PDAUX 

PDAUX 

PDAUX 

PDAUX 

PDAUX 

PDAUX 

PDAUX 

PDAUX 

PDAUX 

PDAUX 

PDAUX 

PDAUX 

PDAUX 

PDAUX 

PDAUX 

PDAUX 

PDAUX 

PDAUX 

PDAUX 

PDAUX 

PDAUX 

PDAUX 

PDAUX 

PDAUX 

PDAUX 

PDAUX 

PDAUX 

PDAUX 

PDAUX 

PDAUX 

PDAUX 

PDAUX 

PDAUX 

PDAUX 

PDAUX 

PDAUX 

PDAUX 

PDAUX 

PDAUX 

PDAUX 

PDAUX 

PDAUX 

FDAUX 

PDAUX 

PDAUX 

PDAUX 

PDAUX 

PDAUX 

PDAUX 


ft 

M 


REGT(N)  =  RGTTL ( 4 ) 

PDAUX 

SEGT(N)  =  SEG(M) 

PDAUX 

DO  17  1=1,3 

PDAUX 

XTEST(I.N)  =  SGTEST (I ,4,M) **2 

PDAUX 

17 

VAR(I.N)  =  SEGLV(I , M) 

PDAUX 

18 

CONTINUE 

PDAUX 

NEQ  =  3*N 

PDAUX 

GO  TO  40 

PDAUX 

20 

IF  (KDINT. NE. 1)  GO  TO  30 

PDAUX 

c 

PDAUX 

c 

KDINT  =  1,  1ST  STEP  IN  ADVANCING  INTEGRATING  INTERVAL, 

PDAUX 

c 

SAVE  DC  MATRICES  IF 

TIME  HAS  ADVANCED. 

PDAUX 

c 

PDAUX 

N  =  0 

PDAUX 

DO  22  M= 1 , MBAG 

PDAUX 

IF  (NTST(M) , LT.O)  GO  TO  22 

PDAUX 

N  =  N+l 

PDAUX 

DO  21  J= 1 , 3 

PDAUX 

DO  21  1=1,3 

PDAUX 

21 

SD(I.J.N)  =  D(I,J.M) 

PDAUX 

22 

CONTINUE 

PDAUX 

c 

PDAUX 

c 

KDINT  >  0,1  -  FETCH  SAVED  DC  MATRICES  AND  UPDATE  BT  CURRENT 

THETA. PDAUX 

c 

PDAUX 

c 

(A)  UPDATE  D  BY  Q 

PDAUX 

c 

PDAUX 

30 

N  =  0 

PDAUX 

DO  32  M= 1 , MBAG 

PDAUX 

IF  (NTST(M) .LT.O)  GO  TO  32 

PDAUX 

N  =  N+l 

PDAUX 

EDOTE  =  VAR(1,N)»»2  +  VAR(2,N)««2 

+  VAR(3,N)**2 

PDAUX 

IF  (EDOTE. GE. 1.0)  KDINT  =  -KDINT 

PDAUX 

IF  (KDINT. LE.O)  GO  TO  99 

PDAUX 

E1(N)  =  DSQRTd.O- EDOTE) 

PDAUX 

CALL  DSETQ(SD( 1 , 1 ,N) ,VAR(1,N) .EDOTE, El (N) ,D(1,1,M)) 

PDAUX 

32 

CONTINUE 

PDAUX 

c 

PDAUX 

c 

KDINT  >  0  -  STORE  STATE  VARIABLES 

INTO  PROGRAM  ARRAYS. 

PDAUX 

c 

PDAUX 

c 

(B)  SEGLP  OF  REFERENCE  SEGMENTS 

PDAUX 

c 

PDAUX 

DO  35  M= 1 . MBAG 

PDAUX 

IF  (LSEG(M) )  GO  TO  35 

PDAUX 

N  =  N+l 

PDAUX 

DO  34  1=1,3 

PDAUX 

34 

SEGLP ( I , M)  =  VAfid ,N) 

PDAUX 

35 

CONTINUE 

PDAUX 

c 

PDAUX 

c 

(C)  WMEG 

PDAUX 

c 

PDAUX 
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DO  31  M=1,MBAG 
IF  (NTST(M) .LT.O)  GO  TO  31 
N  =  N+l 
DO  36  1=1,3 

36  WMEG ( I ,  M)  =  VAB(I.H) 

31  CONTI HUE 

(D)  SEGLV  OF  REFERENCE  SEGMENTS 

DO  38  M= 1 , MBAG 
IF  (LSEG(M) )  GO  TO  38 
N  =  N+l 
DO  37  1=1,3 

37  SEGLV ( I , M)  =  VAR(I.N) 

38  CONTINUE 

CALL  DAUX  ROUTINE  TO  COMPUTE  DERIVATIVES 

40  CALL  DAUX(O) 

STORE  DERIVATIVES  FOR  INTEGRATING  SUBROUTINE. 

(A)  DERIVATIVE  OF  Q 
N  =  0 

DO  39  M= 1 , MBAG 
IF  (NTST(M) .LT.O)  GO  TO  39 
N  =  N+l 

CALL  CROSS  (VARC 1  ,N)  .WMEGd  ,M)  ,  VXT) 

DO  41  1=1,3 

41  DER(I.N)  =  0 . 5* (El (N) * WMEG (I ,M)  +  VXT(I)  ) 

39  CONTINUE 
NQUAT  =  N 

(B)  SEGLV  OF  REFERENCE  SEGMENTS 

DO  43  M= 1 , MBAG 
IF  (LSEG(M) )  GO  TO  43 
N  =  N+l 
DO  42  1=1,3 

42  DER(I.N)  =  SEGLV ( I , M) 

43  CONTINUE 

(C)  WMEGD 

DO  47  M= 1 , MBAG 
IF  (NTST(M) .LT.O)  GO  TO  47 
N  =  N+l 
DO  44  1=1,3 

44  DER(I.N)  =  WMEGD ( I , M) 
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47  CONTINUE 


C 

C 

C 


(D)  SEGLA  OF  REFERENCE  SEGMENTS 


DO  46  Ms 1 , MBAG 
IF  (LSEG(M) )  GO  TO  46 
N  =  N+l 
DO  45  1=1,3 

45  DER(I.N)  =  SEGLA ( I , M) 

46  CONTINUE 

IF  (KDINT.NE.4)  GO  TO  99 
48  N  =  0 

DO  51  M= 1 , MBAG 
IF  (NTST(M) . LT.O)  GO  TO  51 
N  =  N+l 
E1(N)  =  1.0 
DO  50  1=1,3 

DER(I.N)  =  0. 5*WMEG(I , M) 

50  VAR(I.N)  =  0.0 

51  CONTINUE 

99  IF  (KDINT.EQ. 2)  KDINT  =  NQUAT 
CALL  ELTIME(2,6) 

RETURN 

END 
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SUBBOUT I NE  PLEDQ ( ABEAL , BD , PL)  PLEDG 

C  BEV  IV  12/ I 1/87HYFIX 

IMPLICIT  BEAL»8 (A-H.O-Z)  PLEDG 

LOGICAL  ABEAL  PLEDG 

DIMENSION  BD( 24) , PL (24)  HYFIX 

DIMENSION  HABEA(2,2,5) ,ZC(3.14) ,X(3) ,UV(3 , 2) , IV( 14)  HYFIX 

C  SHABED  WITH  PLELP-PLSEGF  HYFIX 

COMMON/TEMPVS/DMNT (3,3) ,DHNT(3,3) , DUM1 (18) ,TM(3) ,B(3) ,BM(3) ,  HYFIX 
X  DUM2(9) ,UP(3) ,VP(3) ,U(3) ,V(3) ,EU(3) ,EV(3) ,ET(3) ,  HYFIX 

X  A ( 2 ) ,B(2) ,CC(2) , DUM4(12) ,TH(3) ,XH(3) , RMD(3) ,BND(3) ,  HYFIX 

X  APT (2, 2, 2) ,AC(2,2) ,BC(2,2) ,AFP,E(2,2) .DELT.ABEA,  HYFIX 

X  AB,BB,BT(2) ,XNC(3) ,UH(3) ,P ,AMB,FM,T4 (3) ,ALIM(2,2)  HYFIX 

EQUIVALENCE  (UV(l.l) ,U(1))  HYFIX 

EQUIVALENCE  (ALIM(1 ,1) ,BMIN) , (ALIM( 1,2) ,AMIN)  HYFIX 

EQUIVALENCE  (ALIM(2 , 1) .BMAX) , (ALIM(2 ,2) .AMAX)  HYFIX 

EQUIVALENCE  (AC (1,1) ,BB1) , (AC (1,2) ,AA1)  HYFIX 

EQUIVALENCE  (AC (2 . 1) ,BB2) , (AC (2 ,2) . AA2)  HYFIX 

EQUIVALENCE  (BC ( 1 , 1) ,AB1) . (BC(1 ,2) ,BA1)  HYFIX 

EQUIVALENCE  (BC(2, 1) ,AB2) , (BC(2,2) ,BA2)  HYFIX 

C  HYFIX 

ABEA  =0.0  PLEDG 

ABEAL  =  .FALSE.  PLEDG 

CALCULATE  CENTEB  OF  ELLIPSE  IN  PLANE  PLEDG 

C  T4  IS  VECTOB  FBOM  CENTEB  OF  ELLIPSOID  TO  CENTEB  OF  ELLIPSE  PLEDG 

DO  10  I  «  1,3  PLEDG 


T4 (I)  =  FM*XH(I) 

10  XNC(I)  =  XNC(I)  +  T4 (I ) 

C  XNC  PI  TO  CENTEB  OF  ELLIPSE 

C  PUT  PLANE  VECTOBS  IN  ELLIPSE  SYSTEM  TH  IS  PLANE  VECTOB 
IF  (BD(1) .LT.0.0)  CALL  MAT33(BD(8) .DMNT.DHNT) 

IF  (BD( 1) .LT.0.0)  GO  TO  20 
DO  15  I  =  1,3 
DO  15  J  =  1,3 
15  DHNT(I.J)  =  DMNT(I,J) 

20  CALL  MAT31 (DHNT,PL(  8) ,UP) 

CALL  MAT31 (DHNT,PL( 13) , VP) 

CALL  MAT31 (DHNT,PL(18) ,  U) 

CALL  MAT31 (DHNT,PL(21) ,  V) 

C  U  IS  P2  -  PI,  V  IS  P3  -  PI,  PLANE  VECTOB  IS  TM 
CALCULATE  CENTEB  FBOM  PI  IN  U,  V  COOBDIHATES 


GET 


25 


B  ( 1) 

B  (2) 
AMIN 
AMAX 
BMIN 
BMAX  = 
ELLIPSE 


(UP ( 1 ) *XNC ( 1 ) 
(VP ( 1) *XHC (1) 
-B  ( 1 ) 

1.0  -  B ( 1 ) 

-B  (2) 

1.0  -  B ( 2 ) 

EQUATION 


♦  UP  (2)  »XNC  (2)  ♦ 

♦  VP (2)  »XNC  (2)  * 


UP (3) *XNC (3) ) /PL (12) 
VP (3) *XHC (3) ) /PL (17) 


DO  25  I  =  1,2 
DO  25  J  =  1,2 
E(I.J)  =  0.0 
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$ 

& 
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IF  (BD ( 1) .GT.O.O)  GO  TO  35 

C  TREAT  HYPER  AS  ELLIPSE  FOR  FIRST  GUESS 
DO  30  I  =  1,3 
EU<I)  =  0(1) »BD(I+16) 

30  EV(I)  =  V { I ) »BD(I+16) 

C  GET  INTERSECTION  OF  PLANE  WITH  BOX 
CALL  HYB0X(BD(2) ,TH,T4 ,MB ,ZC , IV) 

IF  (MB.LT.6)  GO  TO  140 
GO  TO  40 

35  CALL  MAT31 (BD(7) ,U,EU) 

CALL  1IAT31  (BD(7)  ,V,EV) 

40  DO  45  K  =  1,3 

E  ( 1 , 1)  =  E(l,l)  +  U(K) »EU(K) 

E(l, 2)  =  E(l, 2)  ♦  V ( K) »EU (K) 

45  E  (2 , 2)  =  E  (2 . 2)  +  V(K)«EV(K) 

DELT  =  E (1 , 1) *E (2 , 2)  -  E(l,2)**2 

C  WHAT  ABOUT  AMR  FOR  HYPER??  1  -  FM*»P  ? 

R2D  =  AMR/DELT 

COMPUTE  BOUNDS  OF  ELLIPSOID  LOCATION  OF  MAX  AND  MIN  ALPHA 
AA2  =  DSQRT(E(2,2) •R2D) 

AA1  =  -AA2 

C  BA  IS  VALUE  OF  BETA  AT  AT  ALPHA  MAX 
BA1  =  E (1 ,2) *AA2/E (2 , 2) 

BA2  =  -BA1 

IF  (BD(1) .GE.-2.0)  GO  TO  50 
CALL  HYBND (MB ,ZC , IV.UP, -1 . , X) 

CALL  HYLIM(AA1 ,U,BA1 , V,FM,XH,X,BD) 

50  AMIN  =  DMAX1 (AA1 .AMIN) 

IF  (AMIN.GE. AMAX)  GO  TO  140 
IF  (BD(1) .GE. -2.0)  GO  TO  55 
CALL  HYBND (MB, ZC, IV, UP,  l.,X) 

CALL  HYLIM(AA2 ,U,BA2 , V.FM.XH.X.BD) 

55  AMAX  =  DMI N 1 ( AA2 , AMAX) 

IF  (AMIN.GE. AMAX)  GO  TO  140 

COMPUTE  BOUNDS  OF  ELLIPSOID  LOCATION  OF  MAX  AND  MIN  BETA 
BB2  =  DSQRT (E ( 1,1) «R2D) 

BB1  =  -BB2 

C  AB  IS  VALUE  OF  ALPHA  AT  AT  BETA  MAX 
AB1  =  E (1 , 2) »BB2/E (1,1) 

AB2  =  -AB1 

IF  (BDd)  .GE.-2.0)  GO  TO  60 
CALL  HYBND (MB ,ZC , IV, VP , -1 . ,X) 

CALL  HYLIM(BB1 , V,AB1 , U,FM,XH,X,BD) 

60  BMIN  =  DMAX1 (BB1 ,BMIN) 

IF  (BMIN.GE.BMAX)  GO  TO  140 
IF  (BD(1) .GE.-2.0)  GO  TO  85 
CALL  HYBND ( MB, ZC, IV, VP,  l.,X) 

CALL  HYLIM(BB2, V.AB2 ,U,FM,XH,X,BD) 

65  BMAX  =  DMIN1 (BB2.BMAX) 

IF  (BMIN.GE.BMAX)  GO  TO  140 
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COMPUTE  ALPHA’S  AT  BMIM  AND  BMAX;  BETA’S  AT  AMIN  AND  AMAX  IF  NOT  ON 
C  ELLIPSOID 

IF  (BD(1) .LT. -2.0)  GO  TO  80 

DO  76  L  =  1,2 

K  =  3  -  L 

DO  75  J  =  1,2 

DIS  =  0.0 

AFP  =  BC(J ,L) 

IF  {ALIM(J.L) . EQ. AC(J,L) }  GO  TO  74 
AFP  =  ALIM(J,L)/E(L,L) 

DISC  =  AMR/E (L.L)  -  DELT»AFP»»2 
DIS  =  0.0 

IF  (DISC. GT. 0.0)  DIS  =  DSQBT(DISC) 

AFP  =  -AFP»E( 1 ,2) 

74  APT ( 1 , J ,L)  =  DMAX1  (AFP-DIS , ALIM( 1 ,K) ) 

APT (2 , J ,L)  =  DMIN1  (AFP+DIS ,ALIM(2 ,K) ) 

75  CONTINUE 

76  CONTINUE 
GO  TO  95 

80  DO  90  L  =  1,2 
K  =  3  -  L 
DO  89  J  =  1,2 
DIS  =  0.0 
BT(1)  *  BC(J.L) 

BT (2)  =  BC(J,L) 

IF  (ALIM(J.L) . EQ.AC(J.L) )  GO  TO  86 

M  =  2 

IF  (ALIM(J.L) . LT.0.0)  M  =  1 
CM  =  BC(M,L)/AC(M,L) 

CL  ^  ALIM(J,L)«CM 
DO  82  I  =  1.3 

82  RM(I)  =  T4  (I)  ♦  ALIM(J,L)»(UV(I,K)  ♦  CM«DV(I,D) 

DO  85  I  =  1,2 

CALL  HYVAL(BT(I) ,UV(1,L) ,RM,BD,I) 

85  BT ( I )  =  BT ( I )  ♦  CL 

88  APT ( 1 , J ,L)  =  DMAX1  ( BT ( 1 ) ,ALIM(1 ,K) ) 

APT (2 , J ,L)  =  DMIN1  ( BT ( 2 ) ,ALIM(2 ,K) ) 

89  CONTINUE 

90  CONTINUE 

C  SET  UP  LEGAL  BOUNDARIES 

C  APT  L  =  1  L  =  2 

C  A-(BMIN)  A-(BMAX)  B- (AMIN)  B-(AMAX) 

C  A+  (BMIN)  AMBMAX)  B+  (AMIN)  B+  (AMAX) 

C  SET  UP  HAREA  (LINE  SEGMENTS)  CLOCKWISE  STARTING  WITH  AMIN 
95  L  =  0 

HAREA (l.l.L+1)  =  AMIN 
HAREA (2, 1 ,L+1)  =  APT(2,1,2) 

HAREA ( 1 , 2 , L+ 1 )  =  AMIN 
HAREA (2 ,2 ,L+1)  =  APT(1,1,2) 

IF  (APT (2 , 1,2). 3E. APT (1,1,2))  L  *  L  ♦  1 
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HAREAd.l.L+1)  =  APT  (1.1.1)  HYFIX 

HAREA(2 , 1 . L+ 1 )  =  BMIN  HYFIX 

HAREA (1 , 2.L+1)  =  APT(2,1.1)  HYFIX 

HAREA(2 , 2 ,L+1 )  =  BMIN  HYFIX 

IF  (APT (2 .1.1) .GE.APT(l.l.l))  L  =  L  +  1  HYFIX 

HAREA(1 , 1 ,L+1)  =  AMAX  HYFIX 

HAREA(2 , 1 ,L+1)  =  APT(1,2,2)  HYFIX 

HAREA( 1 ,2 ,L+1)  =  AMAX  HYFIX 

HAREA(2 , 2 ,L+ 1)  =  APT(2,2,2)  HYFIX 

IF  (APT (2 ,2,2)  .QE. APTd  ,2,2)  )  L  =  L  +  1  HYFIX 

HAREA(1,1,L+1)  =  APT  (2,2,1)  HYFIX 

HAREA(2, 1 ,L+1)  =  BMAX  HYFIX 

HAREA(  1 ,2 ,L+ 1)  =  APTd, 2,1)  HYFIX 

HAREA(2,2,L+1)  =  BMAX  HYFIX 

IF  ( APT (2,2,1) . QE . APT (1,2,1))  L  =  L  ♦  1  HYFIX 

IF  (L.LE.l)  GO  TO  140  HYFIX 

HAREA( 1 , 1 ,L+ 1 )  *  HAREA (1,1,1)  HYFIX 

HAREA(2, 1 ,L+1)  =  HAREA(2,1,1)  HYFIX 

IF  ( BD (1 ) . GE . - 2 )  CALL  PLREAfL, HAREA, AREA, AB ,BB ,E ,DELT , AMR)  HYFIX 

IF  ( BD ( 1) .LT. -2)  CALL  HYRE A (L, HAREA .AREA, AB,BB)  HYFIX 

AREAL  =  AREA. GT. 0.0  HYFIX 

IF  (.NOT. AREAL)  GO  TO  140  HYPER 

C  HYPER 

DO  120  I  =  1.3  HYPER 

RM(I)  =  AB»U(I)  *  BB»V( I)  *  T4fl>  HYPER 

120  RMD(I)  *  RM(I)  HYPER 

COMPUTE  POINT  ON  ELLIPSOID  BELOW  CENTROID  (CONTACT  POTNT?)  PLEDG 

CONVERT  PLANE  VECTOR,  ET  =  E«TM  PLEDG 

C  TRY  TO  USE  OTHER  LOGIC  HYFIX 

IF(BD(1) .LT. 0.0)00  TO  130  HYPER 

CALL  MAT31 (BD(7) ,TM,ET)  PLEDG 

A2  =  TM( 1 ) *ET ( 1)  +  TM(2) *ET (2)  ♦  TM(3)»ET(3)  PLEDG 

A1  =  AB« (TM(1) *EU(1 ) +TM(2) *EU (2) +TM(3) »EU(3) )  HYFIX 

1*FM*  BB« (TM(1 ) «EV( 1) +TM(2) *EV(2) +TM(3) *EV (3) )  HYFIX 

A1  =  A1/A2  HYFIX 

AO  =  (AB*»2»E (1,1)  ♦  2 . *AB»BB»E (1,2)  ♦  BB«*2*E(2,2)  -  AMR) /A2  HYFIX 

DISC  =  Al«»2  -  AO  PLEDG 

IF (DISC. LT. 0.0) DISC  =  0.0  PLEDG 

P  =  A1  ♦  DSQRT (DISC)  PLEDG 

GO  TO  140  HYPER 

COMPUTE  FOR  HYPER  HYPER 

130  CALL  HYVAL(CA,TH,RM,BD, 1)  HYFIX 

P  =  -CA  HYFIX 

CALL  D0T3 1 ( BD ( 8 ) . RMD . RM)  HYPER 

140  RETURN  HYPER 

END  PLEDG 


SUBROUTINE  PLELP ( M , MM . N , NN , NT)  PLELP 

C  REV  IV  02/07/87HYPER 

IMPLICIT  REAL»8 (A-H.O-Z)  PLELP 

LOGICAL  AREAL  EDGE 

COMMON/TABLES/MXNTI , MXNTB ,MXTB1 .MXTB2 ,NTI (50) ,NTAB(1250) .TAB (4 500) PLELP 
COMMON/ SGMNTS/  D(3.3,30)  ,WMEG(3,30)  ,WMEGD(3,30)  .UK3.30)  ,D2(3,30)  .PLELP 
«  SEGLP(3,30) ,SEGLV(3,30) ,SEGLA(3,30) , NSYMC30)  PLELP 

COMMON/FORCES/PSF (7 ,70) ,BSF(4,20) ,SSF(10,40) ,BAGSF(3,20) ,  NCFOBC 

»  PRJNT (7.30), NPANEL ( 5 ) , NPSF , NBSF , NSSF , NBGSF  PLELP 

COMMON/CNTSRF/  PL (24 .30) ,BELT(20 ,8) ,TPTS(6 .8) ,BD(24 ,40)  EDGE 

COMMON/CSTRNT/  A13(3,3,24) ,A23(3,3,24) ,B31(3,3,24) ,B32(3,3,24) ,  PLELP 

*  HHT(3  3,12) ,RK1 (3 , 12) ,BK2(3,12) ,QQ(3,12) ,TQQ(3,12) .PLELP 

«  BQQ(3, 12) ,HQQ(3, 12) ,  SQQ(12) , CFQQ(I2) ,  PLELP 

«  KQ1 (12) ,KQ2(I2) ,KQTYPE(12)  PLELP 

COMMON/RSAVE/  XSG(3 , 20 , 3) .DPMI (3 . 3 , 30) ,LPMI (30) ,  TGM0D7 

*  NSG(9) ,MSG(20,9) , MCG , MCGIN (24 . 5) ,KREF(20,9)  TGM0D7 

COMMON/TEMPVS/DMNT (3 ,3)  , TEMPO, 3)  , B  (3 . 3)  ,XMN(3)  ,RLN(3)  ,XMM(3)  ,  PLELP 

»  TM(3) ,R(3) ,RM(3) ,DMNWN(3) ,RLM(3) ,RN(3) ,VMN(3) ,VR(3) ,  PLELP 

»  WNM(3) ,WCM(3) ,WCN(3) ,VREL(3) ,FFM(3) ,FR(3) ,TQM(3) ,  PLELP 

*  TQN(3) ,TQNT(3) ,T(3) ,H(3) ,TH(3) ,XH(3) ,BMD(3) ,RND(3) ,  EDGE 

»  TD(3) ,TT4(3,4) ,TT5(3.4) ,XNC(3) ,UH(3) .P.AMR.FM.CF,  EDGE 

»  VRM , VRT , VRTS . VRTEST , TF , ELOSS , MCF , NCF  TGM0D7 

CALL  ELTIME( 1,21)  PLELP 

CALL  D0TT33(D(1,1,M) ,D(1.1.N) .DMNT)  PLELP 

DO  10  I  *  1.3  PLELP 

10  XMN(I)  =  SEGLP(I.M)  -  SEGLP(I.N)  PLELP 

CALL  MAT31(D( 1.1, M) .XMN.XMM)  PLELP 

CALL  MAT3 KDMNT.PL (l.NN)  ,TM)  PLELP 

CALL  MAT3 KDMNT.PL (5, NN)  ,TD)  EDGE 

BET  =  0.0  EDGE 

J  =  3  HYPER 

IF (BD(1 ,MM) .LT.O.O)  J  =  4  HYPER 

DO  15  1=1,3  EDGE 

J  =  J  +  1  HYPEB 

XNC(I)  =  XMM(I)  ♦  BD(J,MM)  -  TD(I)  HYPER 

15  BET  =  BET  -  TM(I)»XNC(I)  EDGE 

C  EDGE 

C  BET  IS  FROM  CENTER  OF  FIGURE  TO  PLANE  EDGE 

I F ( BD ( 1 , MM) . GT . 0 . 0 ) GO  TO  30  HYPER 

C  PUT  PLANE  VECTOR  INTO  HYPER  HYPER 

CALL  MAT31(BD(8,MM) .TM.TH)  HYPEB 

CALL  MAT3 1(BD (8 ,MM) ,XNC ,UH)  HYPER 

DO  20  I  =  1,3  HYPER 

XNC(I)  =  UH( I)  HYPER 

UH ( I )  =  DABS(TH(I) )  »BD(I  +  1  , MM)  /BD(K19,MM)  HYPER 

R ( I )  =  BD (1  +  19, MM) / (BD ( K 19 , MM)  -  1.0)  HYPER 

20  RND ( I ) =  UH(I) **R(I)  HYPER 

ALP  =  HYPEN(BD(1 ,MM) ,R,RND)  HYPER 

DO  25  I  =  1,3  HYPER 

POW  =  1 .0/ (BD (1+19, MM)  -  1.0)  HYPER 


XH(I)  =  -DSIQN (BD (1+ 1 ,  MM) » (UH(I) *ALP) **POW,TH(I) )  HYPER 

25  RND(I)  =  XH(I)  HYPER 

BTE  =  TH( 1) «XH( 1)  ♦  TH(2) »XH(2)  ♦  TH(3)«XH(3)  HYPER 

FM  =  BET /BTE  HYPER 

AMR  >  1.0  -  DABS (FM) »» (-BD ( 1 ,MM) )  HYPER 

GO  TO  35  HYPER 

C  CODE  FOR  ELLIPSE  XH  *  E’T  EDGE 

C  EDGE 

30  CALL  MAT31 (BD ( 16 ,MM) , TM,XH)  HYPER 

BTS  =  TM( I) *  XH ( 1 )  ♦  Tftf  ( 2 ) *XH(2)  ♦  TM(3)«XH(3)  EDGE 

BTE  =  -  DSQRT(BTS)  PLELP 

FM  =  BET/BTS  EDGE 

AMR  =  1.0  -BET»FM  EDGE 

C  EDGE 

35  P  =  BET  -  BTE  HYPER 

PSF(l.NPSF)  =  P  PLELP 

MCF  =  NTAB(NT+1)  PLELP 

NCF  =  -MCF  PLELP 

IF(NCF.GT.O)CFQQ(HCF)  =  -999.  PLELP 

IF(P.LE.O.O)  GO  TO  85  HYPER 

C  EDGE 

C  CALL  EDGE  ROUTINE  TO  FIND  IF  ELLIPSOID  INTERSECTS  FINITE  PLANE  EDGE 

C  IF  IT  DOES;  AREAL  WILL  BE  TRUE,  P  WILL  BE  PENETRATION  AT  CENTROID  EDGE 

C  AND  RM  WILL  BE  LOCATION  OF  CENTROID  EDGE 

C  BM  IS  REFERENCED  TO  CENTER  OF  ELLIPSOID  EDGE 

C  USE  OLD  FORMULA  FOR  ROLL-SLIDE?,  I.E.  ROLL-SLIDE  SHOULDN’T  EDGE 

C  CALL  PLEDG  EDGE 

C  EDGE 

LT  =  NTAB(NT)  EDGE 

IF(TAB(LT*22) .LE. 0.0)00  TO  40  HYPER 

C  EDGE 

IF  (AMR. LE. 0.0)  GO  TO  85  HYPER 

IF  (BD(l.MM) .LT.0.0.AND.BD(23,MM) .NE.O.O)  STOP  22  HYPER 

CALL  PLEDG (AREAL , BD ( I , MM) , PL ( 1 , NN) )  EDGE 

IF (.NOT. AREAL) GO  TO  85  HYPER 

PSF(l.NPSF)  =  P  EDGE 

C  EDGE 

40  IF  (TAB (LT+22) . GT . -2 . 0 . AND . AMR. LE . 0 . 0)  GO  TO  85  HYPER 

RHO  =  0.0  HYPER 

IF(MCF.GT.O)RHO  =  TAB(MCF+4)  PLELP 

BETE  =  1.0  +  RHO+P/BTE  HYPER 

I F ( BD ( 1 , MM) . GT . 0 . 0 ) BETE  *  BETE/BTE  HYPER 

IF(BD(1 ,MM) .LT. 0.0) CALL  D0T31 (BD(8 ,MM) .RND.XH)  HYPER 

TRT  =  PM1.0  -  RHO)  EDGE 

J  =  3  HYPER 

IF(BDd.MM)  .LT.O.OJJ  =  4  HYPER 

DO  45  I  =  1,3  HYPER 

J  =  J  +  1  HYPER 

IF (TAB (LT+22) .LE.O.O)RM(I)  =BETE«XH(I)  EDGE 

IF (TAB (LT+22) .GT.O.O)RM(I)  =  RM(I)  -  TRT«TM(I)  EDGE 


RLM(I)  *  RMd)  ♦  BD (J .MM)  HYPER 

45  RNd)  =  RLMd)  +  XMM( I)  HYPER 

CALL  D0T31 (DMNT .RN.RLN)  PLELP 

IF  (TAB(LT*22) .GT.O.O)  GO  TO  55  HYPER 

IF  (TAB(LT*22) .GT.-3.0.AND.TAB(LT+22) .LT.O.O)  GO  TO  55  HYPER 

EDGE 

CHECK  BOUNDARY  USING  OLD  METHOD  EDGE 

DO  50  I  =  8,13,5  HYPER 

IF(PL(I+4,NN) .LE.O.O)GO  TO  50  HYPER 

DIST  =  BLN(1)«PL(I  ,NN)  PLELP 

»  ♦  RLN(2) »PL(I+1 ,NN)  PLELP 

«  ♦  RLN(3) »PL(I+2 ,MN)  -  PL(I+3,NN)  PLELP 

IF((DIST.LE.O.O)  .OR.  (DIST. GT. PLUM  ,NN) ) )  GO  TO  85  HYPER 

50  CONTINUE  HYPER 

EDGE 

55  CALL  PLSEGF (M,N,NT)  HYPER 

DMNWN.VMN.VR.MHM.HCM.WCN.VREL.FFM.FR.TQM.TQN.TQNT.T  EDGE 

FM . CF . VRM . VRT , VRTS . VRTEST . TF , ELOSS  EDGE 

EDGE 

STORE  RESULTS  EDGE 

DO  60  I  =  1,3  HYPER 

60  PSF ( 1*4 ,NPSF)  =  RLN(I)  HYPER 

IF(LPMI(N) .NE.O)  CALL  D0T31 (DPMI (1 , 1 ,N) ,RLN,PSF(5,NPSF) )  EDGE 

IF(MCF.LT.O)GO  TO  65  HYPER 

PSF (2 ,NPSF)  -  FM  PLELP 

PSF(3.NPSF)  =0.0  PLELP 

TRT  =  TF**2  -  FM*»2  PLELP 

IF(TRT.GT.O.O)  PSF(3.NPSF)  =  DSQRT(TRT)  PLELP 

PSF (4 .NPSF)  =  TF  PLELP 

GO  TO  85  HYPER 

PLELP 

ROLL-SLIDE  REVISED  8/18/85  PLELP 

65  DO  70  I  =  1.3  HYPER 

70  PSF(I+1.NPSF)  =  T ( I)  HYPER 

IF(BD(1,MM) .LT.O.O)  STOP  28  HYPER 

CALL  CROSS (TM.WNM.TH)  EDGE 

CALL  MAT31 (BD(16 ,MM) ,TH,UH)  EDGE 

TRT  =  (TM( 1) »UH( 1)  ♦  TM(2) »UH(2)  ♦  TM(3) «UH(3) ) /BTS  EDGE 

DO  75  I  =  1,3  HYPER 

75  RMD(I)  =  DABS(BETE)  *  (UHd)  -  TRT»XH(I))  HYPER 

CALL  CROSS (DMNWN.TM.TH)  EDGE 

CALL  CROSS (WNM.RMD.XNC)  EDGE 

SQQ(NCF)  =  0.0  PLELP 

DO  80  I  =  1.3  HYPER 

80  SQQ(NCF)  =  SQQ(NCF)  +  TM(I)«XNC(I)  -  2.0«TH(I) «VR(I)  HYPER 

CALL  D0T31 (D ( 1 , 1 , M) , XNC ,RQQ( 1 ,NCF) )  EDGE 

85  CALL  ELTIME(2,21)  HYPER 

RETURN  PLELP 

END  PLELP 


SUBROUTINE  PLREA ( L , H , AREA , AB , BB , E , D , R)  HYFIX 

C  REV  IV  12/ 1 1/87HYFIX 

IMPLICIT  REAL*8 (A-H ,0-Z)  PLREA 

COMPUTES  AREA  AND  CENTROID  (TRUE  AREA  =  AREA* ! UxV! /fl)  HYFIX 

c  :uxv:  is  never  computed  :uxv:  *  UxV.t  *  area  of  parallelogram  plrea 

C  THIS  ROUTINE  WILL  ONLY  BE  CALLED  IF  THERE  IS  AN  INTERSECTION  PLREA 

DIMENSION  H(2, 2,5) ,E(2, 2)  HYFIX 

AREA  =0.0  PLREA 

AB  =  0.0  PLREA 

BB  =  0.0  PLREA 

IF  (L.LE.l)  GO  TO  15  HYFIX 

C  =  R/DSQRT (D)  HYFIX 

C12  =  2 . 0*R/D  HYFIX 

Cll  =  C12*E( 1,1)  HYFIX 

C22  ■  C12*E (2 , 2)  HYFIX 

C12  =  C12*E( 1 ,2)  HYFIX 

DO  10  I  =  1 ,L  HYFIX 

COMPUTE  FOR  STRAIGHT  LINE  SEGMENTS  HYFIX 

AR  =  H(1 , 1 , I) *H(2 ,2,1)  -  H(1 ,2,1) *H(2 , 1,1)  HYFIX 

IF  (AR. EQ. 0 . 0)  GO  TO  5  HYFIX 

AB  =  AB  ♦  AR* (H( 1 , 1 , I)  +  H(1,2,I))  HYFIX 

BB  =  BB  ♦  AR* (H(2 , 1 , I)  +  H(2,2,I))  HYFIX 

AREA  =  AREA  ♦  AR  HYFIX 

COMPUTE  FOR  ELLIPSE  HYFIX 

5  AR  =  H(1,2,I)*H(2,1,I+1)  -  H( 1 , 1 , 1*1) *H(2 , 2 . I)  HYFIX 

IF  (AR.EQ.O.O)  GO  TO  10  HYFIX 

ARC  =  AR/C  HYFIX 

IF  (DABS ( ARC)  .GT.  1.0)  ARC  =  DSIGNU.ODO.ARC)  HYFIX 

AR  =  C*DASIN (ARC)  HYFIX 

X21  =  H(l, 1,1+1)  -  H( 1 , 2 , I)  HYFIX 

Y21  =  H(2, 1,1+1)  -  H ( 2 , 2 , I )  HYFIX 

AB  =  AB  +  C12*X21  +  C22*Y21  HYFIX 

BB  =  BB  -  Cl 1*X21  -  C12*Y21  HYFIX 

AREA  =  AREA  +  AR  HYFIX 

10  CONTINUE  HYFIX 

IF  (AREA. LE. 0.0)  GO  TO  15  HYFIX 

AREA  =  3 . 0*AREA  HYFIX 

AB  =  AB/AREA  PLREA 

BB  =  BB/AREA  PLREA 

C  AREA  =  AREA/6.0  HYFIX 

15  RETURN  PLREA 

END  PLREA 


SUBROUTINE  PLSEQF (M,N,NT)  PLSEQF 

BEV  I I I. 5  09/03/85TGM0D7 

IMPLICIT  REAL *8  (A-H.O-Z)  PLSEQF 

COMMON/SQMNTS/  D(3,3,30) ,WMEG(3,30) ,WMEGD(3,30) ,U1(3,30) ,U2(3,30) .PLSEQF 

*  SEQLP(3,30) ,SEGLV(3,30) ,SEQLA(3,30) ,NS7M(30)  PLSEGF 

COMMON/CSTRNT/  A13(3.3,24) ,A23(3.3.24) ,B31 (3,3,24) ,B32(3,3,24) .  PLSEGF 

*  HHT(3,3, 12) ,RX1 (3 , 12) ,RK2(3,12) ,QQ(3,12) ,TQQ(3,12) .PLSEGF 

«  RQQ (3 , 12) ,HQQ (3 ,12) ,SQQ( 12) ,CFQQ( 12) ,  PLSEGF 

*  KQ1 (12) ,KQ2(12) ,KQTYPE(12)  PLSEGF 

COMMON/TEMPVI/  CREST ,TTI (3) ,R1I (3) ,R2I (3) , JSTOP(4 ,2 ,30)  PLSEGF 

COMMON/TABLES/MXNTI , MXNTB .MXTBl ,MXTB2 ,NTI (50) ,NTAB(1250) .TAB (4500) DIMENB 
THIS  COMMON/TEMP VS /  IS  SHARED  BY  PLELP,  PLSEGF  AND  SEGSEG.  PLSEGF 

COMMON/TEMPVS/DMNT (3 , 3)  , TEMPO, 3)  ,B(3,3)  ,XMN(3)  ,RLN(3)  ,XMM(3)  ,  PLSEGF 

»  TM(3) ,R(3) , RM ( 3 ) ,DMNWN(3) ,RLM(3) ,BN(3) ,VMH(3) ,VR(3) .PLSEGF 

«  WMN(3) ,WCM(3) ,WCN(3) ,VREL(3) ,FFM(3) ,FR(3) ,TQM(3) ,  PLSEGF 

*  TQN(3) ,TQNT(3) ,T(3) ,H(3) , T 1 ( 3 ) ,T2(3) , RMD(3) ,RND(3) ,  PLSEGF 

*  TD(3) ,TT4 (3,4) ,TT5 (3 .4) , T3 (3) ,T4 (3) , P , AMR.FM.CF ,  PLSEGF 

*  VRM.VRT.VRTS ,VRTEST,TF,EL0SS,MCF,NCF,T5(3) ,T6(3)  TGM0D7 

VRTEST  =2.0  PLSEGF 

CALL  MAT31 (DMNT,WMEG( 1 ,N) .DMNWH)  PLSEGF 

DO  15  1=1,3  PLSEGF 

VMN(I)  =  SEGLV(I.M)  -  SEGLV(I.N)  PLSEGF 

15  WMN(I)  =  DMNWN(I)  -  WMEG(I.M)  PLSEGF 

CALL  D0T31(D( 1,1, M) ,TM,T)  PLSEGF 

CALL  MAT3 1 (D ( 1 , 1 , M) . VMN . VB)  PLSEGF 

CALL  CROSS (WMEG(1,M) .BLM.WCM)  PLSEGF 

CALL  CROSS (DMNWN.RN.WCN)  PLSEGF 

VRM  =  0.0  PLSEGF 

DO  16  1=1,3  PLSEGF 

VR ( I )  =  VR(I)  +  WCM(I)  -  WCN(I)  PLSEGF 

16  VRM  =  VRM  +  VR(I)»TM(I)  PLSEGF 

VRT  =  0.0  PLSEGF 

DO  17  1=1,3  PLSEGF 

VREL(I)  =  VR(I)  -  VRM*TM(I)  PLSEGF 

17  VRT  =  VRT  +  VREL(I) ##2  PLSEGF 

VRT  =  DSQRT (VRT)  PLSEGF 

CF  =  EVALFD  (P,NTAB(NT+5) , 1)  PLSEGF 

LT  =  NTAB(NT)  PLSEGF 

TAB (LT)  =  P  PLSEGF 

FM  =  1.0  PLSEGF 

PDOT  =  -VRM  PLSEGF 

ELOSS  =0.0  PLSEGF 

IF  (MCF.GT.O)  CALL  FRCDFL (P, PDOT, NT, 1 ,FM, ELOSS)  PLSEGF 

VRTS  =  VRT  PLSEGF 

IF  ( VRT. LT. VRTEST)  VRT  =  VRTEST/ (2 . O-VRT/VRTEST)  PLSEGF 

FF  =  -DABS (FM) *CF/VRT  PLSEGF 

IF  (NCF.GT.O.AND.KQTYPE(NCF) .EQ.6)  FF=0.0  PLSEGF 

FS  =  ( VRTS- VRT )/VRT  PLSEGF 

IF  (NCF. GT.O. AND. KQTYPE(NCF) .EQ.6)  FS=0.0  PLSEGF 

TF  =  0.0  PLSEGF 


L  *  LT+18  PLSEGF 

DO  18  1=1,3  PLSEGF 

L  =  L+l  PLSEGF 

FFM(I)  =  FM*TM(I)  ♦  FF«VREL(I)  +  FS*TAB(L)  PLSEGF 

TF  =  TF  ♦  FFM(I)**2  PLSEGF 

TTI (I)  =  T(I)  PLSEGF 

R1I  (I)  =  RLM(I)  PLSEGF 

18  R2I (1)  =  RLH(I)  PLSEGF 

TF  =  DSQRT(TF)  PLSEGF 

KT  =  MTAB(MT+5)  PLSEGF 

CREST  =  TABdTT+3)  PLSEGF 

CALL  DOT31  (D( 1 , 1 ,M) .FFM.FR)  PLSEGF 

IF  (MCF.LE.O)  GO  TO  21  PLSEGF 

CALL  CROSS  (RLM.FFM.TQlf)  PLSEGF 

CALL  CROSS  (RN.FFII.TQHT)  PLSEGF 

CALL  DOT31  (DMNT ,TQMT ,TQM)  PLSEGF 

DO  19  1=1,3  PLSEGF 

Ul(I.M)  =  01 (I, M)  ♦  FR(I)  PLSEGF 

Ul(I.N)  =  01 (I, H)  -  FR(I)  PLSEGF 

02(1, M)  =  02(1, M)  ♦  TQM(I)  PLSEGF 

19  02 (I. N)  =  02 (I. N)  -  TQN(I)  PLSEGF 

IF  (MCF.LE.O)  GO  TO  23  PLSEGF 

21  DO  22  1=1,3  PLSEGF 

HQQ(I.HCF)  =  FR(I)/TF  PLSEGF 

TQQ(I.HCF)  =  T (I)  PLSEGF 

RKl(I.MCF)  =  RLM(I)  PLSEGF 

22  RK2 (I ,NCF)  =  RLM(I)  PLSEGF 

CFQQ(MCF)  =  CF  PLSEGF 

MT  =  NTAB(HT+5)  PLSEGF 

IF  (KQTYPE(MCF) . EQ.3)  CFOQ(MCF)  =  TAB(¥T+4)  PLSEGF 

23  RETORH  PLSEGF 

EMD  PLSEGF 


SUBROUTINE  PLTXYZ (P.C)  PLTXYZ 

REV  I I I. 5  05/30/85VEHICL 


STORES  PLOT  CHARACTER  (C)  INTO  PLOTYZ,  PLOTXZ  AND  PLOTXY  ARRAYS  PLTXYZ 
IN  VEHICLE  REFERENCE  FOR  POINT  (P)  GIVEN  IN  INERTIAL  REFERENCE.  PLTXYZ 

PLTXYZ 

IMPLICIT  REAL* 8  (A-H.O-Z)  PLTXYZ 

COMMON /CONTm,  /  TI ME , NSEG , N JNT , NPL , NBLT , NBAG , NVEH , NGRND ,  PLTXYZ 

«  NS , NQ ,NSD .NFLX.NHRNSS .NWINDF .NJHTF ,NPRT(36) , NPG  PAGE 

COMMON/SGMNTS/  D(3.3,30) ,WMEG(3,30) ,WMEGD(3,30) ,U1(3,30) ,02(3,30) .PLTXYZ 

*  SEGLP(3,30) ,SEGLV(3,30) ,SEGLA(3,30) ,NSYM(30)  PLTXYZ 

COMMON/ VPOSTN/  ZPLT(3) ,SPLT(3) ,AXV(3.6) ,VATAB(6,501 ,6) .  VEHICL 

*  VT0(6) ,VDT(6) ,TIMEV(6) ,0MEGV(6) ,NVTAB(6) ,INDXV(6)  PLTXYZ 

COMMON/TEMPVS/  DUM(lOl) .PLOTYZ (96 , 55) .PLOTXZ (96, 55) .PLOTXY (96 .55)  PLTXYZ 
LOGICAL* 1  C. PLOTYZ .PLOTXZ, PLOTXY  PLTXYZ 

DIMENSION  P (3) ,TMP(3) ,XYZ(3)  PLTXYZ 

DATA  NPLTZ/96/  .  SPLTX/55/  PLTXYZ 

PLTXYZ 

CONVERT  P  FROM  INERTIAL  TO  VEHICLE  REFERENCE  BY  PLTXYZ 

XYZ  =  DVEH(P-XCOMP)  PLTXYZ 

PLTXYZ 

DO  10  1=1,3  PLTXYZ 

10  TMP(I)  =  P(I)  -  SEGLP ( I , NVEH)  PLTXYZ 

CALL  MAT3 1 (D ( 1 , 1 , NVEH) . TMP , XYZ)  PLTXYZ 

PLTXYZ 

CONVERT  XYZ  INTO  PLOT  CORDINATES  IX.IY.IZ  AND  PLTXYZ 

IF  WITHIN  PLOT  LIMITS.  STORE  C  IN  PLOTYZ,  PLOTXZ  AND  PLOTXY.  PLTXYZ 

PLTXYZ 

IX  =  SPLT (1) *XYZ( 1 )  +  ZPLT(l)  +  0.5  PLTXYZ 

IZ  =  SPLT (3) «XYZ (3)  +  ZPLT(3)  +0.5  PLTXYZ 

IF  (IZ.LT.l  .OR.  IZ.GT.NPLTZ)  GO  TO  11  PLTXYZ 

IY  =  SPLT (2) »XYZ(2)  ♦  ZPLT(2)  +0.5  PLTXYZ 

IF  (IY.GE.l  .AND.  IY.LE.NPLTX)  PLOTYZ (IZ , IY)  =  C  PLTXYZ 

IF  ( IX. GE. 1  .AND.  IX.LE.NPLTX)  PLOTXZ(IZ.IX)  =  C  PLTXYZ 

11  IY  =  -SPLT(3)»XYZ(2)  ♦  ZPLT<2)  +  0.5  PLTXYZ 

IF  (IY.LT.l  .OR.  IY.GT.NPLTZ)  GO  TO  99  PLTXYZ 

IF  (IX.GE.l  .AND.  IX.LE.NPLTX)  PLOTXY ( I Y, IX)  =  C  PLTXYZ 

99  RETURN  PLTXYZ 

END  PLTXYZ 
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SUBROUTINE 

POSTPR (PRDT) 

POSTPR 

c 

REV  IV 

02/01/88MISDOT 

c 

CONTROLS  GENERATION  OF 

PRINTED  TABULAR  TIME  HISTORIES 

POSTPB 

c 

AND  PLOTS 

BY  THE  VALUE 

OF  NPRT (4)  AS  FOLLOWS: 

POSTPR 

c 

POSTPR 

c 

VALUE  OF 

TIME 

POSTPR 

c 

NPRT (4) 

HISTORIES 

PLOTS 

POSTPB 

c 

POSTPR 

c 

♦  4 

** 

NO 

POSTPR 

c 

+3 

YES 

YES 

POSTPR 

c 

+2 

YES 

NO 

POSTPR 

c 

♦  1 

«» 

YES 

POSTPR 

c 

0 

*« 

NO 

POSTPR 

c 

-1 

NO 

YES 

POSTPB 

c 

-2 

YES 

NO 

POSTPR 

c 

-3 

YES 

YES 

POSTPR 

POSTPB 

h  TIME  HISTORIES  WERE  PRINTED  BT  SUBROUTINE  OUTPUT.  POSTPR 

POSTPR 

COMMON/CDINT/  JDTPTS(I8) ,ZZ(1000,3)  PLTIHC 

NOTE:  THIS  OVERWRITES  COMMON  /CDINT/.  POSTPR 

COMMON/CONTRL/  TIME , NSEO , NJNT , NPL , NBLT , NBAG , NVEH , MGRND ,  POSTPR 

*  NS , NQ , NSD , NFLX , NHRNSS , NWI NDF , NJNTF , NPRT ( 36) , NPG  PAGE 

REAL* 8  TIME  POSTPR 

COMMON/FORCES/PSF (7,70) ,BSF(4,20) ,SSF<10,40) ,BAGSF(3,20) ,  NCFORC 

i  PRJNT(7,30) ,NPANEL(5) , NPSF , NBSF , NSSF , NBGSF  POSTPR 

REAL *8  PSF , BSF , SSF , BAGSF , PBJNT  POSTPR 

COMMON/TITLES/  DATE(3) .COMENT (40) ,VPSTTL(20) .BDYTTLC5) ,  POSTPR 

*  BLTTTL(5,8) ,PLTTL(5,30) ,BAQTTL(5,6) ,SEG(30) ,  POSTPR 

*  JOINT(30) ,CGS(30) ,JS(30)  POSTPR 

REAL  DATE. COMENT, VPSTTL . BDYTTL , BLTTTL , PLTTL , BAGTTL , SEG , JOINT  POSTPR 

LOGICAL* 1  CGS.JS  POSTPR 

COMMON/CNSNTS/  PI .RADIAN, G.THIBD.EPS (24) ,  POSTPR 

»  UNITL,UNITM,UNITT,GRAVTY(3) .TWOPI  TWOPI 

REAL* 8  PI, RADIAN, G. THIRD, EPS, UNITL.UNITM.UNITT.GRAVTY  POSTPR 

COMMON/ JBARTZ/  MNPL(  30) ,MNBLT(  8) ,MNSEG(  30) ,MNBAG(  6) ,  POSTPR 

*  MPL (3 , 5,30) ,MBLT(3 ,5 ,8) , MSEG(3 , 5 ,30) ,MBAG(3 , 10,6) ,  POSTPR 

»  NTPLf  5,30) ,NTBLT(  5,8),NTSEG(  5,30)  POSTPR 

COMMON/DAMPER/  APSDM(3,20) ,APSDN(3,20) ,ASD(5,20) ,MSDM(20) ,MSDN( 20) POSTPR 
REAL *8  APSDM.APSDN.ASD  POSTPR 

COMMON/HRNESS/  BAR ( 15 , 100) ,BB ( 100) , BBDOT ( 100) .PLOSS (2 . 100) ,  POSTPR 

*  XLONG(20) ,HTIME(2) ,IBAR(5,100) ,NL(2,100) ,  POSTPR 

*  NPTSPB(20) ,NPTPLY(20) , NTHRNS(20) ,NBLTPH(5)  POSTPR 

REAL *8  B AB,BB, BBDOT, PLOSS, XLONG.HT I ME  POSTPB 

COMMON/RSAVE/  XSG(3,20,3) .DPMI (3,3,30) ,LPMI  (30) ,  ATBIII 

*  NSG(9) ,MSG(20,9) ,MCG,MCGIN(24 ,5) ,KREF(20,9)  TTHKREF 

REAL *8  XSG , DPMI , TD ATA , UMS EC , PRDT , TEST 1 , TEST2 , VDT 1  TGM0D1 

REAL *8  VDT2.R30.R26  TGMODI 

MOTE:  SUBROUTINES  POSTPR  &  HEDING  SHARE  THIS  C01M0N/TEMPVS/ .  POSTPR 

THE  FIRST  DIMENSION  OF  XLAB , YLAB , PLB 1  AND  PLB2  SHOULD  BE  THE  SAME  POSTPR 
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C  AS  THE  VALUE  ASSIGNED  TO  NW60  WHICH  IS  THE  NUMBER  OF  WORDS  THAT  POSTPR 

C  IS  NECESSARY  TO  CONTAIN  60  CONSECUTIVE  CHARACTERS  DEPENDING  ON  THEPOSTPR 

C  COMPUTER  SYSTEM  THIS  PROGRAM  IS  OPERATING  ON.  THE  VALUE  OF  NW60  POSTPR 

C  SHOULD  BE  15  ON  IBM  360  AND  370.  10  ON  UNIVAC  1108,  6  ON  CDC  6600. POSTPR 

C  THE  LAST  TERM  IN  FORMAT  13  BELOW  SHOULD  BE  15A4(IBM),  10A6 (UNIVAC) POSTPR 

C  OR  6A10 (CDC) .  ALSO,  THE  FIRST  DIMENSION  OF  PLDATA  IN  SUBROUTINE  POSTPR 

C  HEDING  SHOULD  BE  97(IBM),  77(UNIVAC)  OR  61 (CDC) .  REDIM2 

C  POSTPR 

COMMON/TEMPVS/  TDATA( 14 ,65) ,HEDATA(470) ,  POSTPR 

*  XO (20) ,XN(20) ,XL(20) ,XS(20) ,XLAB(15,20) ,PLB1 (15,20) .POSTPR 

*  YO (20) , YN(20) , YL(20) ,YS(20) ,YLAB(15,20) ,PLB2(15,20) .POSTPR 

*  NYP(20) , MX (2 ,20) ,MY(2, 10,20) ,NX(20) ,NY(20) ,  POSTPR 

*  NXLAB(20) ,NYLAB(20) ,NPLB1 (20) ,NPLB2(20) ,  POSTPR 

*  USEC(45) ,Z(1000,25) ,ZTTH( 14 , 45 , 65)  MISDOT 

LOGICAL  LTABH , LPLOT  POSTPR 

DATA  LPP/45/  .  NZD1/1000/,  NZD2/25/  PLTINC 

DATA  NW60/15/  POSTPR 

LTABH  =  .FALSE.  POSTPR 

LPLOT  =  .FALSE.  POSTPR 

NPRT4  =  IABS (NPRT (4) )  POSTPR 

LPLOT  =  NPRT4.EQ.1  .OR.  NPRT4.EQ.3  POSTPR 

LTABH  =  NPRT4.EQ.2  .OR.  NPRT4.EQ.3  POSTPR 

IF (NPRT (26) .EQ. 4)  LTABH  =  .FALSE.  TGM0D1 

IF(NPRT(26) .GE.5)  GO  TO  99  TGM0D1 

POSTPR 

READ  INPUT  CARD  H.ll  TO  CONTROL  COMPUTATION  OF  HIC,  HSI  &  CSI.  WINDOP 

POSTPR 

READ  (5,11)  JDTPTS  POSTPR 

WRITE (6, 700)  NPG  PAGE 

NPG=NPG+1  PAGE 

700  FORMAT (1H1.122X,’ PAGE’ ,15/, 2X,  PAGE 

*  'POSTPROCESSOR  CONTROL  PARAMETERS’ ,/)  PAGE 

WRITE (6, 701)  CHGIII 

701  FORMAT (13X, 'HIC  &  HSI  POINT' ,7X, 'CSI  POINT’)  CHGIII 

WRITE(6 ,702)  JDTPTS ( 1) .JDTPTS (2)  CHGIII 

702  FORMAT (5X, ’H.ll’ ,10X,I2,17X,I2,//)  WINDOP 

NDPT  =  0  POSTPR 

IHIC  =  0  TGM0D1 

126  =  0  TGM0D1 

ITST1  =  0  TGM0D1 

ITST2  =  0  TGM0D1 

IF(NPRT(26) .LT.O)  126  =  IABS (NPRT (26) )  TGM0D1 

IF(JDTPTS(1) . GT. 0 .OR. JDTPTS (2) .GT.O)  IHIC  =  1  TGM0D1 

IF (NPRT (30) .EQ.O. AND. NPRT (26) .EQ. 3)  ITST1  =  1  TGM0D1 

I F ( NPRT ( 30 ) . LT . 1 26 )  ITST2  =  1  TGM0D1 

IFdHIC.EQ.  1  .AND.  ITST1  .EQ.  1)  WBITE(6,751)  TGM0D1 

IF (IHIC.EQ. 1 .AND. ITST2.EQ. 1)  WRITE(6,752)  NPRT(30),I26  TGM0D1 


751  70RMAT(3X, 'WARNING!  LOGIC  OF  INPUT  INDICATES  USEB  ANTICIPATES  HICTGM0D1 
».  HSI  AND  CSI  TO  BE  COMPUTED  BASED  ON  DATA  FOR  EVERY  SUCCESSFUL’,  TGM0D1 
»/,10X, ’INTEGRATION  STEP,  YET  DATA  WAS  STORED  (WRITTEN  TO  TAPES)  EVTGMOD 1 


320 


o  o  o  o  o  o  non  o  o  o 


«ERY  DT. ’ )  TGM0D1 

752  FORMAT (3X, ’WARNING!  LOGIC  OF  IHPUT  INDICATES  USER  ANTICIPATES  HICTGM0D1 

« ,  HSI  AND  CSI  TO  BE  COMPUTED  BASED  ON  DATA  FOR  EVERY  ’ .I2./.10X.’  TGMOD1 
« INTEGER  MULTIPLE  OF  DT,  YET  DATA  WAS  STORED  (WRITTEN  TO  TAPES)  EVETGMOD1 
»RY  M2,’  INTEGER  MULTIPLE  OF  DT.')  TGMOD1 

IF(JDTPTSd)  .GT.0.AND.NPRT(26)  .EQ.2. AND.NPRT(30)  .LT.  I)  STOP  91  TGM0D1 
IF (JDTPTS (2) . GT.O. AND.NPRT(2Q) . EQ. 2 . AND. NPRT (30) . LT. 1 )  STOP  92  TGM0D1 
IF  (JDTPTS ( 1) .NE.O)  NDPT  =  NDPT  ♦  l  POSTPR 

IF  (JDTPTS (2) .NE.O)  NDPT  =  NDPT  ♦  1  POSTPR 

IF  ( . NOT . LPLOT  .AND.  . NOT . LTABH  .AND.  NDPT.EQ.O)  GO  TO  99  POSTPR 

CALL  ELTIME  (1,36)  POSTPR 

IF  (.NOT. LPLOT)  GO  TO  20  POSTPR 

C  POSTPR 

C  READ  INDICES  OF  VARIABLES  TO  BE  PLOTTED  AND  POSTPR 

C  ARGUMENTS  TO  SUBROUTINE  SLPLOT  ON  CARDS  I.  POSTPR 

C  POSTPR 

C  INPUT  CARD  1.1  POSTPR 

C  POSTPR 

READ  (5,11)  NPLT  ,  (NYP(K) ,K=1 ,NPLT)  POSTPR 

11  FORMAT  (1814)  POSTPR 

IF(NPLT. GT.O. AND. ITST1. EQ. 1)  WBITE(6,753)  TGM0D1 

IF (NPLT. GT.O. AND. ITST2.EQ. 1)  WBITE(6,754)  NPRT(30),I26  TGM0D1 

753  FORMAT (3X, ’WARNING!  LOGIC  OF  INPUT  INDICATES  USER  ANTICIPATES  PLOTGMOD 1 
«TS  TO  BE  COMPUTED  BASED  ON  DATA  FOR  EVERY  SUCCESSFUL  INTEGRATION  STGM0D1 
«TEP’ ,/ , 10X, 'YET  DATA  WAS  STORED  (WRITTEN  TO  TAPE8)  EVERY  DT.’)  TGM0D1 

754  FORMAT (3X,’ WARNING!  LOGIC  OF  INPUT  INDICATES  USER  ANTICIPATES  PLOTGMOD 1 

»TS  TO  BE  COMPUTED  BASED  ON  DATA  FOB  EVERY  ’,12 ,/, 10X, ’ INTEGER  MULTTGMOD 1 
•PLE  OF  DT,  YET  DATA  WAS  STORED  (WRITTEN  TO  TAPES)  EVERY  ',12,  TGM0D1 

»  1  INTEGER  MULTIPLE  OF  DT. ’)  TGM0D1 

IF  (NPLT.LE.O)  LPLOT  =  .FALSE.  POSTPR 

IF  (.NOT. LPLOT)  GO  TO  20  POSTPR 

DO  15  K= 1 , NPLT  POSTPR 

NYPLT  =  NYP(K)  POSTPR 

POSTPR 

INPUT  CARD  I.2.K  POSTPR 

POSTPR 

READ  (5,11)  MX( 1 ,K) ,  MX(2,K),  <MY(1,J,K),  MY(2,J,K),  J*l, NYPLT)  POSTPR 

POSTPR 

INPUT  CARD  I.3.K  POSTPR 

POSTPR 

READ  (5,12)  NX(K) ,  XO(K),  XN(K) ,  XL(K) ,  XS(K)  POSTPR 

12  FORMAT  (14  ,  4X  ,  4F8.0  )  POSTPR 

POSTPR 

INPUT  CARD  I.4.K  POSTPR 

POSTPR 

READ  (5,12)  NY(K) ,  YO(K) ,  YN(X) ,  YL (K) ,  YS(K)  POSTPR 

POSTPR 

INPUT  CARD  I.5.K  POSTPR 

POSTPR 

READ  (5,13)  NXLAB(K),  (XLAB ( I ,X) , I- 1 ,NW60)  POSTPR 


13  FORMAT  (14  ,  4X  ,  15A4)  POSTPB 

POSTPR 

NOTE  -  ABOVE  FORMAT  ASSUMES  4  ALPHANUMERIC  CHARACTERS  FOR  SINGLE  POSTPR 
PRECISION  WORDS  ON  IBM  360  AND  370  COMPUTERS.  THE  15A4  TERM  IN  THEPOSTPB 
FORMAT  WILL  HAVE  TO  BE  CHANGED  ON  NON- IBM  COMPUTERS  TO  PRODUCE  A  POSTPR 


CONTINUOUS  STRING  OF  60  CHARACTERS  IN  CORE  MEMORY.  POSTPR 

POSTPB 

INPUT  CARD  I.6.K  POSTPR 

POSTPR 

READ  (5,13)  NYLAB(K) ,  (YLAB(I,K) ,1=1 ,NW60)  POSTPR 

POSTPR 

INPUT  CARD  I.7.K  POSTPR 

POSTPR 

BEAD  (5,13)  NPLB1 (X) ,  (PLB1 (I ,K) ,1=1 ,NW60)  POSTPR 

POSTPR 

INPUT  CARD  I.8.K  POSTPB 

POSTPR 

15  READ  (5,13)  NPLB20C) ,  (PLB2(I,K) ,I=1,NW60)  POSTPR 

CHGIII 

WRITE  OUT  PLOTTING  CONTROL  DATA  CHGIII 

CHGIII 

WRITE (6 ,703)  CHGIII 

703  FORMAT (4X, ’PLOTTING  CONTROLS',/)  CHGIII 

WRITE(6,704)  CHGIII 

704  FORMAT (12X,’ NO.  PLOTS’ , 1 IX, 'NO.  OF  Y  VARIABLES  PER  PLOT’)  CHGIII 

WRITE(6 ,705)  NPLT, (NYP(JK) ,JK*1 ,NPLT)  CHGIII 

705  FORMAT (5X, ’ I . 1 ’ , 7X, 12, 7X, 20 (I2,2X) )  CHGIII 

WRITE (6, 706)  CHGIII 

706  FORMAT ( 12X,’ MX 1  MX2  MYiA  MY2A  MY1B  MY2B  MY1C  MY2C  MY1D  MY2D  MY1E  MCHGIII 

*Y2E  MY1F  MY2F  MY1G  MY2G  MY1H  MY2H  MY1I  MY2I  MY1J  MY2J’ )  CHGIII 

DO  730  I J= 1 ,NPLT  CHGIII 

WRITE(6,707)  IJ.MXO , I J) ,MX(2,IJ) ,  CHGIII 

«  (MY(1,L,IJ) ,MY(2,L,IJ) ,L=1 ,NYP(IJ) )  CHGIII 

707  FORMAT (5X, ’1.2.' , 12 ,2X, 12 ,2X,I2 ,2X,20 (12 ,3X) )  CHGIII 

730  CONTINUE  CHGIII 

WRITE (6, 708)  CHGIII 

708  FORMAT ( 1 4X , ’ NX ’ , 8X , ’ XO ’ , 9X , ’ XN ’ , 6X , ’ XL ’ , 9X , ’ XS ’ )  CHGIII 

DO  731  IJ= 1 , NPLT  CHGIII 

WRITE (6 ,709)  IJ.NX(IJ) ,XO(IJ) ,XN(IJ) ,XL(IJ) ,XS(IJ)  CHGIII 

709  FORMAT (5X, '1.3. ' , 12 , 2X , 13 , 4X, 4 (F8 . 3 , 2X) )  CHGIII 

731  CONTINUE  CHGIII 

WRITE (6 ,710)  CHGIII 

710  F0RMAT(14X, ’NY’ ,8X, ’YO’ ,9X, ’YN’ ,8X, ’YL’ ,9X, ’YS’)  CHGIII 

DO  732  IJ= 1 ,NPLT  CHGIII 

WRITE(6 ,711)  IJ,NY(IJ) ,YO(IJ) ,YN(IJ) , YL(IJ) ,YS(IJ)  CHGIII 

711  FORMAT (5X, ’1.4. ’ , 12 , 2X , 13 , 4X, 4 (F8 . 3 , 2X) )  CHGIII 

732  CONTINUE  CHGIII 

WRITE(8,712)  CHGIII 

712  F0RMATU2X,  ’NXLAB’  ,  15X,  ’XLAB’ )  CHGIII 

DO  733  I J= I, NPLT  CHGIII 


m 


m 


m 


WRITE (6 ,713)  IJ.NXLAB(IJ) . (XLAB(L.IJ) ,L=1.NW60) 

713  FORMAT (5X, '1.5. ’ ,12. 2X, 13, 5X.15A4) 

733  CONTINUE 
WRITE(6,714) 

714  FORMAT ( 1 2X , ’ NYLAB ’ , 1 5X , * YLAB 1 ) 

DO  734  IJ= 1 ,NPLT 

WRITE(6 ,715)  IJ.NYLAB(IJ) . (YLAB(L.IJ) ,L=1,NW60) 

715  FORMAT ( 5X , ’ I . 6 . ’ ,I2,2X,I3,5X, 15A4) 

734  CONTINUE 
WRITE(6 ,716) 

716  FORMAT ( 1 2X,  'NPLB1'  ,15X,'PLBr) 

DO  735  IJ= 1 ,NPLT 

WRITE(6,717)  IJ.NPLBl  ( I J )  ,  (PLBKL.IJ)  ,L=1,NW60) 

717  FORMAT (5X, ’1.7. ’ ,I2,2X,I3,5X, 15A4) 

735  CONTINUE 
WRITE(6 ,718) 

710  FORMAT ( 12X, ' NPLB2 ’ , 15X, 'PLB2' ) 

DO  736  IJ= 1 ,NPLT 

WRITE(6 ,719)  IJ , NPLB2 ( I J ) , (PLB2(L,IJ) ,L=1,NW60) 

719  FORMAT (5X. '1.8. ’ ,I2,2X,I3,5X, 15A4) 

736  CONTINUE 

READ  TIME  HISTORY  DATA  FROM  TAPE  8. 

20  NPTS  =  0 
LINES  =  0 

IF  (NPBT(4) .GT.O)  REWIND  8 

READ  (8, END* 29)  NSEG , NJNT , NPL , NBLT , NBAG , NVEH , NQRND , NPANEL , 

»  MNPL , MNBLT , MNSEG , MNBAG , MPL , MBLT , MSEG , MBAG 

READ  (8 .END-29)  DATE , COMENT , VPSTTL , BDYTTL , BLTTTL , PLTTL , BAGTTL , 
«  SEG , JOINT , UNITL , UNITM , UNITT , NSG , MSG . XSG , MCG , 

*  MCGIN, KREF , NHRNSS , NBLTPH , NPTSPB , NSD , MSDM . MSDN 

21  READ  (0 ,END=29)  NT,  UMSEC,  ( (TDATACI ,J) ,1=1 , 14) ,J=1 ,NT) 

R30  =  l.ODO 

IF(NPRT(30) .GT.O)  R30  =  NPRTI30) 

VDT1  =  R30*PRDT 

TEST1  =  DMOD( UMSEC, VDT1) 

TEST1  =  DMIN1 (TEST1 ,DABS(VDT1  -TEST1 ) ) 

IF(NPRT(30) .GT.O. AND. TEST1 .GT.EPSI4) )  GO  TO  25 
NPTS  =  NPTS  ♦  1 

IF  (NPTS.GT.NZD1  .AND.  (NDPT.NE.O  .OR.  LPLOT)  )  STOP  52 
ZZ(NPTS.l)  =  UMSEC 
Z(NPTS.l)  =  UMSEC 
IF  (NDPT.EQ.O)  GO  TO  22 

STORE  DATA  FOR  HIC,  HSI  AND  CSI. 

JJ  =  1 

DO  61  1*1,2 

IF  (JDTPTS(I) . EQ. 0)  GO  TO  61 


CHGIII 

CHGIII 

CHGIII 

CHGIII 

CHGIII 

CHGIII 

CHGIII 

CHGIII 

CHGIII 

CHGIII 

CHGIII 

CHGIII 

CHGIII 

CHGIII 

CHGIII 

CHGIII 

CHGIII 

CHGIII 

CHGIII 

CHGIII 

CHGIII 

POSTPR 

POSTPR 

POSTPR 

POSTPR 

POSTPR 

POSTPR 

POSTPR 

POSTPR 

POSTPR 

ATBIII 

CHGIII 

POSTPR 

TGM0D1 

TGM0D1 

TGM0D1 

TGM0D1 

TGM0D1 

TGM0D1 

POSTPR 

ATBIII 

PLTINC 

PLTINC 

POSTPR 

POSTPR 

POSTPR 

POSTPR 

POSTPR 

POSTPR 

POSTPR 


non  non 


JJ  =  JJ  +1  POSTPB 

JD  =  JDTPTS ( I )  -  1  POSTPB 

JE  =  4«M0D(JD,3)  ♦  4  POSTPB 

JP  =  JO/3  ♦  1  POSTPB 

ZZ(HPTS.JJ)  =  TDATA(JE.JP)  PLTIMC 

61  CONTINUE  POSTPB 

22  IF  ( .NOT.LPLOT)  GO  TO  25  POSTPB 

POSTPB 

STOBE  DATA  FOB  PLOTTING  POSTPB 

POSTPB 

JY  =  1  PLTINC 

DO  24  K= 1 , NPLT  POSTPB 

JE  =  IABS (MX(2 ,X) )  POSTPB 

IF  (JE.EQ.O)  GO  TO  23  POSTPB 

JY  =  JY  ♦  1  POSTPB 

IF  (JY.GT.NZD2)  STOP  53  ATBIII 

JP  =  MX(l.K)  -  20  POSTPB 

Z(NPTS.JY)  *  TDATA(JE.JP)  POSTPB 

23  NYPLT  =  NYP(K)  POSTPB 

DO  24  J=l, NYPLT  POSTPB 

JY  =  JY  +  1  POSTPB 

JP  =  MY( 1 ,  J,K)  -  20  POSTPB 

IF  (JY.GT.NZD2)  STOP  54  ATBIII 

JE  =  IABS (MY(2 , J ,K) )  POSTPB 

Z(NPTS , JY)  =  UltSEC  POSTPB 

24  IF  (JE.NE.O)  Z(NPTS.JY)  =  TDATA(JE.JP)  POSTPB 

25  IF  ( . NOT . LTABH)  GO  TO  21  POSTPB 

POSTPB 

STOBE  DATA  TO  PBINT  TABULAB  TIME  HISTOBIES  POSTPB 

POSTPB 

B26  =  1.0D0  TGM0D1 

IF(NPBT(26) .LT.O)  IFLG  =  1  TGM0D1 

IFdFLG.EQ.  1)  N26  =  IABS (HPBT (26) )  TGM0D1 

IF(IFLG.EQ. 1)  B26  *  N26  TGM0D1 

VDT2  =  B26»PBDT  TGM0D1 

TEST2  =  DMO D ( UMSEC , VDT2 )  TGM0D1 

TEST2  =  DMIN1 (TEST2 ,DABS (TDT2  -  TEST2) )  TGM0D1 

IF  (NPBT(26) .LE.O  .AND.  TEST2 .GT.EPS (4) )  GO  TO  21  TGM0D1 

LINES  =  LINES  ♦  1  POSTPB 

NTTH  =  MOD (LINES- l.LPP)  ♦  1  POSTPB 

USEC(NTTH)  =  UMSEC  POSTPB 

DO  26  J=1 ,NT  POSTPB 

DO  26  1=1,14  POSTPB 

26  ZTTHd.NTTH.J)  =  TDATA(I.J)  POSTPB 

IF  (NTTH.EO.LPP)  CALL  HEDING  (LINES ,LPP)  POSTPB 

GO  TO  21  POSTPB 

29  IF  (.NOT. LTABH  .OB.  LINES. EQ.O)  GO  TO  30  POSTPB 

IF  (NTTH.NE.LPP)  CALL  HEDING  (LINES, LPP)  POSTPB 

30  IF  (NDPT.NE.O)  CALL  HICCSI(HPTS)  POSTPB 

IF  (.NOT.LPLOT)  GO  TO  98  POSTPB 
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c 
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41 

42 


43 

44 


50 


« 

« 


POSTPB 

PLOT  DATA  VIA  SUBBOUTINE  SLPLOT. 

POSTPB 

POSTPB 

INCLUDE  ANY  PBOGBAM  STATEMENTS  BEBE  BEQUIBED  BY 

YOUB 

COMPUTES  AND  POSTPB 

PLOTTING  SYSTEMS  FOB  PLOT  INITIALIZATION  (E.G. , 

CALL 

PLOTS) 

POSTPB 

POSTPB 

CALL  PLOTS  (0.0,0.0,10) 

FIXSPT 

JZ  =  1 

PLTINC 

DO  50  K=1 , NPLT 

POSTPB 

JX  =  1 

POSTPB 

IF  (MX(2,K) .EQ.O)  GO  TO  42 

POSTPB 

JZ  =  JZ  ♦  1 

POSTPB 

JX  =  JZ 

POSTPB 

IF  (Z(l.JX) .EQ.0.0  .OB.  MX(2,K) .GE.O)  GO  TO  42 

POSTPB 

DO  41  1=2 ,HPTS 

POSTPB 

Z(I.JX)  =  Z(I.JX)  -  Z(1,JX) 

POSTPB 

Z(1,JX)  =  0.0 

POSTPB 

NYPLT  =  NYP(K) 

POSTPB 

DO  44  J=l, NYPLT 

POSTPB 

JY  =  JZ  ♦  J 

POSTPB 

IF  (Z(1,JY) .EQ.0.0  .OB.  MY(2,J,K) .GE.O)  GOTO 

44 

POSTPB 

DO  43  1=2 ,NPTS 

POSTPB 

Z ( I , JY)  =  Z ( I , JY)  -  Z(1,JY) 

POSTPB 

Z(l.JY)  =  0.0 

POSTPB 

CONTINUE 

POSTPB 

NXK  =  NX(K) 

POSTPB 

NYK  =  NY (K) 

POSTPB 

XOK  =  XO (K) 

POSTPB 

YOK  =  YO (K) 

POSTPB 

XNK  =  XN(K) 

POSTPB 

YHK  =  YN(K) 

POSTPB 

XLK  =  XL(K) 

POSTPB 

YLK  =  YL(K) 

POSTPB 

XSK  =  XS(K) 

POSTPB 

YSK  =  YS(K) 

POSTPB 

NXLABK  =  NXLAB(K) 

POSTPB 

NYLABK  =  NYLAB(K) 

POSTPB 

NPLB1K  =  NPLBKK) 

POSTPB 

NPLB2K  =  NPLB2 (K) 

POSTPB 

CALL  SLPLOT (Z( 1 , JX  ),  NXK,  XOK,  XNK,  XLK.  XSK, 

XLAB( 1 ,K) , 

NXLABK, POSTPB 

Zd.JZ+l),  NYK,  YOK,  YNK,  YLK,  YSK, 

YLAB(l.K) . 

NYLABK, POSTPB 

NPTS, NYPLT, NZD1 , PLB1 (1 ,K) .NPLB1K.PLB2 ( 1 ,K) .NPLB2K)  POSTPB 

POSTPB 

INSEBT  AMT  CODE  REQUIRED  BY  YOUB  SYSTEM  TO  ADVANCE  PLOT  PAGES  HEBEPOSTPB 


POSTPB 

IF(NPBT(31) .EQ.l)  GO  J  444  CHGIII 
XOO  =  -0 . 5» (XSK- (XLK-v . 5) )  ♦  XLK  ♦  3.0  FXPLOT 
YOO  =  -0 . 5» (YSK- (YLK-1 . 0) )  FXPLOT 
CALL  PLOT  (XOO. YOO, -3)  FXPLOT 
JZ  =  JZ  ♦  NYPLT  POSTPB 
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SUBROUTINE  PRINT (SUB) 

REV  IV 

SUBROUTINE  TO  PRINT  SEQUENT  LINEAR  AND  ANGULAR 
POSITIONS,  VELOCITIES  AND  ACCELERATIONS  FOR  A  GIVEN  TIME. 

ARGUMENTS 

SUB:  CALLING  SUBROUTINE  NAME 
IMPLICIT  REAL*8 (A-H.O-Z) 

COMMON/ CONTRL/  T I ME , NSEG . N JNT , NPL , NBLT , NB AG , NVEH , NGRND . 

»  NS , NO , NSD , NFLX , NHRNSS , NWI NDF , NJNTF , NPRT ( 36 )  , NPG 

COMMON/ SGMNTS/  D(3,3.30) ,WMEG(3,30) , WMEGD ( 3 . 30 ) ,01(3,30) ,U2(3,30) .PRINT 


PRINT 

07/24/86SLIP 
PRINT 
PRINT 
PRINT 
PRINT 
PRINT 
PRINT 
PRINT 
PRINT 
PAGE 


SEGLP (3 , 30) , SEGLV (3 , 30) ,SEGLA(3,30) ,NSYM(30) 


PRINT 


COMMON/DESCRP/  PHI (3,30) ,W(30) ,RW(30) ,SR(4,60) ,HA(3,60) ,HB(3,60) ,  SLIP 

»  RPHI (3,30) ,HT (3 , 3 ,60) , SPRING (5 ,90) , VISC (7 ,90) ,  PRINT 

*  JNT(30) ,IPIN(30) ,ISING(30) ,IGL0B(30) ,J0INTF(30)  PRINT 

COMMON/CMATRX/  VI (3,30) ,V2(3,30) ,V3(3,12) ,B12 (3,3,60) ,A22(3,3,60) .PRINT 

*  F (3 , 30) ,TQ(3 ,30) , WJ (30) , A1 1 (3 , 3,30)  SLIP 

COMMON/CSTRNT/  A13(3,3,24) ,A23(3,3,24) ,B31 (3,3,24) ,B32(3,3,24) ,  PRINT 


HHT(3 ,3, 12) , RK1 (3 , 12) ,RK2(3,12) ,QQ(3,12) ,TQQ(3,12) .PRINT 


*  RQQ (3 ,12) , HQQ (3,12) . SQQ (12) ,CFQQ(12) . 

»  KQ1 (12) ,KQ2(12) ,KQTYPE(12) 

COMMON/TITLES/  DATE ( 3 ) ,COMENT(40) ,VPSTTL(20) .BDYTTL (5) , 

*  BLTTTL (5,8) ,PLTTL(5,30) ,BAGTTL(5,6) ,SEG(30) , 

»  J0INT(30) ,CGS(30) ,JS(30) 

REAL  DATE , COMENT , VPSTTL  BDYTTL , BLTTTL , PLTTL , BAGTTL , SEG .JOINT 
LOGICAL* 1  CGS.JS 

COMMON/CEULER/  IEULER(30) ,HIR(3,3,90) ,ANG(3,30) ,ANGD(3,30) , 

*  FE(3,30) ,TQE(3,30) ,C0NST(5,30) 

COMMON/CNSNTS/  PI .RADIAN, G, THIRD, EPS(24) , 

»  UNITL,UNITM,0NITT,GRAVTY(3) .TWOPI 

COMMON/RSAVE/  XSG(3,20,3) .DPMI (3 ,3 ,30) ,LPMI (30) , 

«  NSG (9) , MSG (20 ,9) ,MCG,MCGIN(24 .5) ,KREF(20,9) 

COMMON/ TEMP VS/  YPR(3) ,T1 (3) ,T2(3) ,HH(3) ,T3(3,3) ,SKE(3) ,TKE(3) ,V 


IPC  =  1 

TMSEC  =  1000 . 0*TIME 

WRITE  (6,11)  I PC, SUB, TMSEC, NPG 

NPG=NPG+1 

11  FORMAT  (1 1 ,6X,A6, ’  FUNCTIONS  FOR  TIME= ’ 

*  F10 . 3  ,  ’  MSEC’ ,75X, ’PAGE M5/) 

WRITE  (6,760) 

760  FORMAT ( IX, 23X, ’ (INERTIAL) ’ ,29X, ’ (LOCAL) 
WRITE  (6,12)  UNITT.UNITT 

12  FORMAT (19X, ’ANGULAR  ROTATION  (DEG)’, 


,35X, ’ (LOCAL) ’) 


*  12X, 'ANGULAR  VELOCITY  (RAD/ ’ , A4 , ’ ) ’ , 

*  12X, ’ANGULAR  ACCELERATION  (RAD/ ’ , A4 , ’ **2) ’ / 

*  ’  SEGMENT’ .9 X, ’YAW’  ,7X, ’PITCH' ,7X, ’ROLL’ , 

*  11X,’X',11X,’Y’,11X,'Z’,15X, ’X’ ,13X,’Y’ ,13X,’Z’/) 
MBAG  =  NVEH  +  NBAG 


PRINT 

PRINT 

PRINT 

PRINT 

PRINT 

PRINT 

PRINT 

JDRIFT 

JDRIFT 

PRINT 

TWOPI 

ATBIII 

TTHKREF 

KINETIC 

PRINT 

PRINT 

PRINT 

PAGE 

PAGE 

CHGIII 

PAGE 

CHGIII 

CHGIII 

PRINT 

PRINT 

PRINT 

PRINT 

PRINT 

PRINT 

PRINT 


wmm 
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DO  20  1=1, MBAG  PRINT 

IF  (LPMI (I) .EQ.O)  GO  TO  19  PRINT 

CALL  D0T33  (DPMI (1 , 1 , I) ,D(1 . 1 ,1) ,T3)  PRIHT 

CALL  D0T31 (DPMI (1,1,1) ,VMEG(1 ,1) ,T1)  FIXPRT 

CALL  D0T31 (DPMI (1,1,1) , WMEGDtl ,1) , T2)  FIXPRT 

CALL  YPRDEG  (T3.YPR)  PRIHT 

WRITE  (6,31)  I , SEG(I) , YPR, ( T 1 (K) , K=1 ,3) , (T2 (K) ,K=1 ,3)  FIXPRT 

GO  TO  20  PRIHT 

19  CALL  YPRDEG  (D( 1 , 1 , I) ,YPR)  PRIHT 

WRITE  (6,31)  I,SEG(I) ,YPR, (WMEG(X.I) ,X=1,3) . (WMEGD(K.I) ,K*1,3)  FIXPRT 

20  COHTIHUE  FIXPRT 

WRITE (6. 770)  CHGIII 

770  FORMAT (// , 1X.23X, ’ (INERTIAL) ’  .27 X,  ’ (INERTIAL) ’ ,32X, ’ (INERTIAL) ’ )  CHGIII 
WRITE  (6,22)  UHITL ,  (JHITL ,  UHITT  PRIHT 

22  FORMAT (18X, ’Ll HEAR  POSITION  ( ’ , A4 , ’ ) ‘ ,  CHGIII 

»  13X, ’LINEAR  VELOCITY  ( ' ,A4 , ’ / ’ , A4 , ’ ) ’ ,  PRIHT 

*  16X, ’LINEAR  ACCELERATIONS  (G”S)’/  PRIHT 

»  ’  SEGMENT’, lOX.’X’.lOX.’Y’.lOX.’Z’.  PRIHT 

»  13X,’X\llXf’Y’,llX,’Z’,15X,’X'.13X,’Y’,13X,’Z’/)  PRIHT 

DO  30  1=1, MBAG  PRIHT 

DO  29  K=1 ,3  PRIHT 

29  T1(K)  =  SEGLA(K,I)/G  PRIHT 

30  WRITE  (6,31)  I , SEG ( I ) , (SEGLP(K.I) ,K=1 ,3) , (SEGLY(K.I) ,K=1 ,3) ,T1  PRIHT 

31  FORMAT (13 , IX, A4 , 3X.3F1 1 . 4 ,3X,3F12. 5 ,3X,3F14 .6)  PRINT 

IF  (NSEG.GT.6)  WRITE  (6,32)  HPG  PAGE 

IF  (NSEG.GT.6)  NPG=NPG+1  PAGE 

32  FORMATCl’ ,122X, ’PAGE’ ,15)  PAGE 

WRITE(6,775)  CHGIII 

775  FORMAT(//, IX, 23X, ’ (INERTIAL) ’,29X,’ (LOCAL)’)  CHGIII 

WRITE  (6,33)  UHITL, UHITT, UHITT, UNITM, UHITL  KINETIC 

33  FORMAT ( 18X, ’U1  ARRAY  ( ' , A4 , ’/ ’ , A4 , ’ «*2) ’ ,  KINETIC 

«  14X,’U2  ARRAY  (RAD/ ’ , A4 , ’ **2) ’ ,  KINETIC 

»  25X, ’KINETIC  ENERGY’/  KINETIC 

«  15X, 'EXTERNAL  LINEAR  ACCELERATIONS’,  KINETIC 

»  8X. ’EXTERNAL  ANGULAR  ACCELERATIONS’ ,  KINETIC 

»  22X , ’ ( ’ , A4 , ' - ’ , A4 , ’ ) ’ /  KINETIC 

«  ’  SEGMENT’, 10X.’X’,10X,’Y',10X,’Z’,13X,’X’,11X,’Y’.11X,’Z’,  KINETIC 

»  14X, ’LINEAR’, 7X, ’ANGULAR’, 7X,’T0TAL’/)  KINETIC 

DO  80  J=1 ,3  KINETIC 

80  TKE (J) =0 . 0  KINETIC 

DO  34  1=1 ,NSEG  PRINT 

V=SEGLV (1,1) »»2+SEGLV(2 , I) »*2+SEGLV(3 , I) **2  KINETIC 

SKE ( 1) =0 . 5«W(I ) *V/G  KINETIC 

SKE(2) =0.0  KINETIC 

DO  81  J=1 ,3  KINETIC 

81  SKE (2) =SKE (2) +0 . 5*PHI ( J , I ) *WMEG(J , I) *»2  KINETIC 

SXE(3) =SKE ( 1 ) +SKE (2)  KINETIC 

DO  82  J=1 ,3  KINETIC 

82  TKE ( J) =TKE ( J) +SKE ( J)  KINETIC 

IF  (LPMI (I) .EQ.O)  GO  TO  73  FIXPRT 


CALL  D0T31  (DPMI  (1 ,1,1)  ,112(1,1)  ,T1)  FIXPBT 

WHITE  (6,61)  I,SEQ(I)  .  (OKK.I)  ,K=1,3)  ,  KINETIC 

»  (T 1 (K) ,K=1 ,3) , (SKE(K) ,K=1 ,3)  KIHETIC 

GO  TO  34  PBIHT 

73  CONTINUE  PBINT 

WHITE  (6,61)  I , SEG(I) , ( U 1 ( K , I ) , K=1 ,3) ,  KINETIC 

«  (U2(K, I) ,K=1 ,3) , (SKE(K) ,K=1 ,3)  KINETIC 

61  FOBMAT (13 , IX, A4 ,3X,3(D1 1.4, IX) , 3X, 3 (D12 . 5 , IX) ,3X,3 (D12.5 , IX) )  KINETIC 

34  CONTINUE  FIXPBT 

WBITE(6 ,83)  (TKE(K) ,K=1 ,3)  KINETIC 

83  FOBMAT (1X.98X, ’TOTAL  BODY  KINETIC  ENEBGY’/  KINETIC 

*  1X.90X.3 ( 1X.D12. 5) )  KINETIC 

IF  (NJNT.LE.O)  GO  TO  39  PBINT 

WHITE(6,776)  CHGIII 

776  FORMAT (// , IX, 27X, ’ (INERTIAL) ’ , 27X, ' (INEBTIAL) ’ )  CHGIII 

WRITE  (6,35)  UNITM.UNITL.UNITM.UNITT  PRINT 

35  FORMAT (24X, ’JOINT  FORCES  (’,A4,’)’,  CHGIII 

»  15X, ’JOINT  TORQUES  (’,2A4,’)’,  PRINT 

«  9X. ’RELATIVE  ANGULAR’/  PRINT 

*’  JOINT  I PIN’ ,9X,’X’ , 10X, ’ Y’ ,10X,*Z’ ,13X,‘X’ ,11X,’Y’ ,11X,’Z’ ,  PRINT 

*  7X. ’VELOCITY  (RAD/’ ,A4, ') ’/)  PRINT 

DO  36  J=  1 , NJNT  PRINT 

IPINJ  =  IPIN(J)  PRINT 

IF  ( IABS ( IPIN( J) ) .EQ.4)  IPINJ  =  IEULEB(J)  PRINT 

DO  137  11=1,3  MISC 

137  T 1 (II) =-TQ(II ,  J)  MISC 

WRITE  (6,37)  J, JOINT (J) , IPINJ, (F(K,J) ,K=1 ,3) , (T1 (K) ,K=1 ,3) ,WJ(J)  MISC 
37  FORMAT (13 ,1X,A4,I4,7X,3(D10.3,1X) ,3X,3 (D1 1 , 4 , IX) ,3X,F13.3)  FIXPRT 

36  CONTINUE  FIXPBT 

39  IF  (NQ.LE.O)  GO  TO  99  PRINT 

WRITE  (6,41)  CHGIII 

WRITE  (6,47)  CHGIII 

47  FORMAT ( IX, 45X, ’ (INERTIAL) ’)  CHGIII 

WRITE  (6,49)  UNITM.UNITL  CHGIII 

41  FORMAT (///’  OTHER  CONSTRAINT  FORCES’,/)  CHGIII 

49  FORMAT (IX.’  NO.  TYPE  SEG1  SEG2 ' ,  CHGIII 

*  15X, 'CONSTRAINT  FORCE  (’ ,A4, ’)’ ,  PRINT 

»  16X. ’DISTANCE  (’,A4,’)’/)  PRINT 

ICH  =  0  FIXPBT 

DO  50  J  = 1 , NQ  PRINT 

IF  (KQTYPE(J) .NE.5)  ICH  =  0  FIXPRT 

IF  (KQTYPE(J) .LT.O)  GO  TO  50  PRINT 

IF  (KQTYPE(J) .EQ.5)  ICH  =  ICH  +  1  FIXPBT 

IF  (ICH.EQ.2)  GO  TO  50  FIXPRT 

M  =  KQl(J)  PBINT 

N  =  KQ2 (J)  PRINT 

CALL  D0T3 1 ( D ( 1 , 1 , M) , RK 1 ( 1 , J ) , T 1 )  PBINT 

CALL  D0T31 (D ( 1 , 1 ,N) , RK2 ( 1 , J) ,T2)  PRINT 

SI  =  0.0  PRINT 

DO  42  1=1,3  PRINT 


HH(I)  =  SEQLP(I , M) +T1 (I)  -  SEQLP(I ,N) -T2(I)  PBIMT 

42  SI  =  SI  ♦  HH(I)»»2  PBIMT 

SQS1  =  DSQBT(Sl)  PBIMT 

WBITE  (6,43)  J.KQTYPE(J) , SEG(M) ,SEG(H) , (QQ(I ,J) ,1=1 ,3) ,SQS1  PBIMT 

43  FOBMAT ( I 4 , I 6 , 4X , A4 , 2X , A4 , 3X , 3G 1 5 . 7 , 6X , G 1 5 . 7 )  PBIMT 

50  CONTINUE  PBIMT 

99  IF  (NPBT(28) .LE.O)  NPBT(20)  =  -1  PBIMT 

BETUBM  PBIMT 

END  PBIMT 
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SUBROUTINE  PRIPLT  PRIPLT 

REV  IV  07/24/86SLIP 

PRODUCES  PRINTER  PLOT  OF  Y-Z  PLANE  VIEW  AND  X-Z  PLANE  VIEW  OF  PRIPLT 
BODY  SEGMENT  CGS,  JOINTS  AND  SELECTED  POINTS  OF  VEHICLE  COMPONENTSPRIPLT 

PRIPLT 

IMPLICIT  REAL *8  (A-H.O-Z)  PRIPLT 

COMMON/CONTRL/  T I ME , NSEG , NJNT , NPL , NBLT , NBAG , NVEH , NGRND ,  PRIPLT 

»  NS , NQ , NSD , NFLX , NHRNSS , NWI NDF , NJNTF , NPRT ( 36 ) , NPG  PAGE 

COMMON/SGMNTS/  D(3,3,30) ,WMEG(3,30) ,WMEGD(3,30) ,U1(3,30) ,U2(3,30) .PRIPLT 

*  SEGLP(3,30) ,SEGLV(3,30) ,SEGLA(3,30) ,NSYM(30)  PRIPLT 

COMMON/DESCRP/  PHK3.30)  ,W(30)  ,RW(30)  ,SR(4,60)  ,HA(3,60)  ,HB(3,60)  ,  SLIP 

*  RPHI (3,30) ,HT(3,3,60) .SPRING (5 ,90) , VI SC (7, 90) ,  PRIPLT 

»  JNT(30) ,IPIN(30) ,ISING(30) ,IGLOB(30) ,JOINTF(30)  PRIPLT 

COMMON/ JB ARTZ /  MNPL(  30) ,MNBLT(  8) , MNSEG(  30) ,MNBAG(  6) ,  PRIPLT 

*  MPL (3 , 5 , 30) ,MBLT (3 ,5,8) , MSEG(3 , 5,30) ,MBAG(3 ,10,6) ,  PRIPLT 

»  NTPL (  5,30) ,NTBLT(  5,8),NTSEG(  5,30)  PRIPLT 

COMMON/ CNTSRF/  PL(24 , 30) .BELT (20 , 8) ,TPTS (6 ,8) ,BD(24 . 40)  EDGE 

COMMON/ TITLES/  DATE(3) ,C0MENT(40) ,VPSTTL(20) ,BDYTTL(5) ,  PRIPLT 

*  BLTTTL(5,8) ,PLTTL(5,30) ,BAGTTL(5,6) ,SEG(30) ,  PRIPLT 

*  JOINT (30) , CGS (30) ,JS (30)  PRIPLT 

COMMON/HRNESS/  BAR( 15 . 100) ,BB ( 100) ,BBDOT ( 100) .PLOSS (2 , 100) .  PRIPLT 

t  XL0NG(20) ,HTIME(2) ,IBAR(5,100) ,NL(2,100) ,  PRIPLT 

*  NPTSPB(20) ,NPTPLY(20) ,NTHRNS(20) ,NBLTPH(5)  PRIPLT 

REAL  DATE , COMENT , VFSTTL , BDYTTL , BLTTTL , PLTTL , BAGTTL , SEG , JOINT  PRIPLT 

LOGICAL* 1  CGS.JS  PRIPLT 

COMMON/TEMPVS/  TEMPI  (3)  , TEMPO)  ,TEMP2(3)  ,CJ0INT(3, 30)  ,BSN(2)  ,  PRIPLT 

*  PLOTYZ (96 , 55) , PLOTXZ (96 , 55) ,PL0TXY(96 ,55)  PRIPLT 

LOGICAL* 1  PLOTYZ, PLOTXZ, PLOTXY, CHARS (7) .BLANK, BCHAR  PRIPLT 

LOGICAL  NPRT5 , NPRT6 , NPRT7  PRIPLT 

DATA  CHARS/ ,  BLANK/’  ’/  PRIPLT 

DATA  I STEP/O/  ,  NPLTI/96/  ,  NPLTJ/55/  PRIPLT 

PRIPLT 

DETERMINE  IF  PLOTTING  IS  TO  BE  DONE  FOR  THIS  TIME  STEP.  PRIPLT 

PRIPLT 

ISTEP  =  ISTEP+1  PRIPLT 

NPRT5  =  (NPRT (5) ,EQ. 1)  PRIPLT 

IF  (NPRT(5) .GT. I)  NPRT5  =  ( MOD ( I  STEF , NPRT ( 5 ) ) . EQ . 1 )  PRIPLT 

NPRT6  =  (NPRT (6) .EQ. I)  PRIPLT 

IF  (NPRT(6) .GT. 1)  NPRT6  =  (MOD (I STEP, NPRT (6) ) .EQ. 1)  PRIPLT 

NPRT7  =  (NPRT(7) .EQ. 1)  PRIPLT 

IF  (NPRT(7) .GT. 1)  NPRT7  =  (MOD (I STEP, NPRT (7) ) .EQ. 1)  PRIPLT 

IF  ( . NOT. NPRT5  .AND.  . NOT . NPRT8  .AND.  . NOT. NPRT7)  GO  TO  99  PRIPLT 

CALL  ELTIME(1,  4)  PRIPLT 

PRIPLT 

BLANK  OUT  PLOT  ARRAYS.  PRIPLT 

PRIPLT 

DO  10  J  =  1 , NPLTJ  PRIPLT 

PLOTYZ ( 1 . J)  =  CHARS (6)  PRIPLT 

PLOTXZ ( 1 . J)  =  CHARS (6)  PRIPLT 

PLOTXY ( 1 , J)  *  CHARS (6)  PRIPLT 


DO  10  1=2 .NPLTI  PBIPLT 

PLOTYZ(I.J)  =  BLANK  PBIPLT 

PLOTXZ(I.J)  =  BLANK  PBIPLT 

10  PLOTXYd  ,  J)  =  BLANK  PBIPLT 

PBIPLT 

PLOT  VEHICLE  BEFEBENCE  OBIGIN  USING  SYMBOL («) .  PBIPLT 

PBIPLT 

CALL  PLTXYZ  (SEGLP ( 1 ,NVEH) .CHABS (7) )  PBIPLT 

PBIPLT 

PLOT  CG  OF  BODY  SEGMENTS  USING  SEGMENT  SYMBOLS.  PBIPLT 

PBIPLT 

DO  20  1=1, NSEG  PBIPLT 

20  CALL  PLTXYZ (SEGLP (1, I ) ,CGS (I))  PBIPLT 

PBIPLT 

COMPUTE  AND  PLOT  JOINT  LOCATIONS  USING  JOINT  SYMBOLS.  PBIPLT 

PBIPLT 

IF  (NJNT.EQ.O)  GO  TO  40  PBIPLT 

DO  31  J=1 , NJNT  PBIPLT 

I  =  IABS ( JNT (J) )  PBIPLT 

IF  (I.LE.O)  GO  TO  31  PBIPLT 

CALL  D0T31 (D(l , 1 ,1) ,SB(1 ,2*J-1) .TEMP)  PBIPLT 

DO  30  L= 1 , 3  PBIPLT 

30  CJOINT(L.J)  =  TEMP (L) + SEGLP (L, I)  PBIPLT 

CALL  PLTXYZ  (CJOINTd  ,J)  ,JS(J) )  PBIPLT 

31  CONTINUE  PBIPLT 

IF  (NPBT(13) .NE.O)  WBITE(6,32)  ( (CJOINT(I ,J) . 1= 1 .3) ,J=1 .NJNT)  PBIPLT 

32  FOBMAT  CO  JOINT  POSITIONS '/( 1X.9F14 .4) )  PBIPLT 

PBIPLT 

PLOT  BELT  ANCHOB,  FIXED  AND  TANGENT  POINTS  USING  SYMBOL!.).  PBIPLT 

PBIPLT 

40  IF  (NBLT.LE.O)  GO  TO  50  PBIPLT 

DO  43  J  = 1 , NBLT  PBIPLT 

IF  (MNBLT(J) .LE.O)  GO  TO  43  PBIPLT 

Ml  =  MBLT(l.l.J)  PBIPLT 

M2  =  MBLT (2 , 1 , J)  PBIPLT 

M3  =  MBLT ( 3 , 1 , J )  PBIPLT 

DO  41  1=1,3  PBIPLT 

41  TEMPI (I)  =  BELT ( I +6, J)  ♦  BD(I+3,M3)  PBIPLT 

CALL  D0T31  (D(l , 1 ,M2) .TEMPI .TEMP)  PBIPLT 

CALL  D0T31  (D ( 1 , 1 .Ml) ,BELT( 1 ,J) .TEMPI)  PBIPLT 

CALL  D0T31  (Dd  ,  1  ,M1)  ,BELT(4,J)  .TEMP 2)  PBIPLT 

DO  42  1=1,3  PBIPLT 

TEMPI (I)  =  TEMPI (I)  ♦  SEGLP ( I ,M1)  PBIPLT 

TEMP2 (I)  =  TEMP2(I)  ♦  SEGLP (I. Ml)  PBIPLT 

42  TEMP  (I)  =  TEMP  (I)  ♦  SEGLP(I,M2)  PBIPLT 

CALL  PLTXYZ  (TEMPI  , CHABS (D)  PBIPLT 

CALL  PLTXYZ  (TEMP2  .CHABS (D)  PBIPLT 

CALL  PLTXYZ  (TEMP  , CHABS ( 1 ) )  PBIPLT 

CALL  PLTXYZ  (TPTS(1 ,J) .CHABS(l) )  PBIPLT 

CALL  PLTXYZ  (TPTS (4 , J) ,CHABS(1) )  PBIPLT 


43  CONTINUE  PBIPLT 

PRIPLT 

PLOT  POINTS  IN  PLAY  ON  HARNESS-BELT  SYSTEMS  USING  SYMBOL!.).  PRIPLT 

PRIPLT 

50  IF  (NHRNSS.LE.O)  GO  TO  80  PRIPLT 

J 1  =  1  PF.IPL7 

K1  =  1  PRIPLT 

DO  54  NH=1 .NHRNSS  PRIPLT 

IF  (NBLTPH(NH) . LE.O)  GO  TO  54  PRIPLT 

J2  =  J1  ♦  NBLTPH(NH)  -  1  PBIPLT 

DO  53  NB=J1,J2  PRIPLT 

IF  (NPTPLY(NB) .LE.O)  GO  TO  53  PRIPLT 

K2  =  K1  ♦  NPTPLY(NB)  -  1  PRIPLT 

DO  52  K=K1,K2  PRIPLT 

KI  =  NL(1,K)  PRIPLT 

KS  =  IABS(IBARU.KI))  PRIPLT 

IF  (KS.GT.100)  KS  =  MOD (KS, 100)  PRIPLT 

CALL  D0T31  (D(l , 1 ,KS) ,BAB(4,KI) .TEMPI)  PRIPLT 

CALL  D0T31  (D(l , 1 ,KS) ,BAR(7,KI) .TEMP2)  PRIPLT 

DO  51  1=1,3  PRIPLT 

51  TEMP ( I )  =  SEGLP(I.KS)  ♦  TEMPI (I)  ♦  TEMP2(I)  PRIPLT 

52  CALL  PLTXYZ  ( TEMP, CHARS ( 1) )  PRIPLT 

Kl  =  K2+1  PRIPLT 

53  CONTINUE  PRIPLT 

J1  =  J2+1  PBIPLT 

54  CONTINUE  PRIPLT 

PBIPLT 


PLOT  CENTER  AND  END  OF  AXES  OF  ELLIPSOIDAL  TARGET  USING  SYMBOLS  PRIPLT 
(•)  FOR  CENTER.  (-)  FOR  ENDS  OF  Z  AXIS,(!)  FOR  ENDS  OF  X,Y  AXES.  PBIPLT 


PRIPLT 

60  IF  (NBAG.EQ.O)  GO  TO  80  PBIPLT 

BSN(l)  =  1.0  PRIPLT 

BSN(2)  =  -1.0  PRIPLT 

DO  88  J  = 1 , NBAG  PBIPLT 

IF  (MNBAG(J) . EQ.O)  GO  TO  68  PRIPLT 

JB  =  NVEH+J  PRIPLT 

BCHAR  =  CHARS (5)  PRIPLT 

L2  =  2  PRIPLT 

DO  67  1=1,4  PBIPLT 

IF  (I.EQ.3)  BCHAR  =  CHARS (4)  PRIPLT 

IF  (I.EQ.4)  BCHAR  =  CHARS (3)  PRIPLT 

IF  (I.EQ.4)  L2  =  1  PRIPLT 

DO  67  L=1,L2  PRIPLT 

DO  64  K= 1 ,3  PRIPLT 

64  TEMPI (K)  =  BD(K+3 , JB)  PBIPLT 

IF  (I.EQ.4)  GO  TO  65  PRIPLT 

TEMPI (I)  =  TEMPI (I)  ♦  BSN(L) «BD(I , JB)  PRIPLT 

65  CALL  D0T31  (D( 1 , 1 ,JB) .TEMPI .TEMP2)  PRIPLT 

DO  66  K=1 ,3  PRIPLT 

66  TEMP2(K)  =  TEMP2 (K)  ♦  SEGLP(K.JB)  PRIPLT 
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67  CALL  PLTXYZ  (TEMP2 .BCHAR) 

68  CONTINUE 

PRINT  Y-Z  ,  X-Z  AND  X-Y  PLANE  VIEW  PLOTS. 

80  TMSC  =  1000 . 0*TIME 

IF  ( .N0T.NPBT5)  GO  TO  83 

WRITE  (2.81)  TMSC , SEGLP ( 2 , NVEH) , SEGLP ( 3 , NVEH) 

81  FORMAT  Cl  T=’,F10.3,’  Y0=\F10.5.’  Z0=’,F10.5,’ 

WRITE  (2,82)  PLOTYZ 

82  FORMAT  (2X.96A1) 

83  IF  (.N0T.NPRT6)  GO  TO  85 

WRITE  (2.84)  TMSC, SEGLP (1. NVEH) .SEGLP (3, NVEH) 

84  FORMAT  (’ 1  T=’ .F10.3, ’  X0=’,F10.5.’  Z0*',F10.5,’ 

WRITE  (2,82)  PLOTXZ 

85  IF  ( .M0T.MPRT7)  GO  TO  87 

WRITE  (2.86)  TMSC. SEGLP (1, NVEH) .SEGLP (2, NVEH) 

86  FORMAT  (’1  T=’ .F10.3,’  X0=’ .F10.5, ’  Y0*’,F10.5,’ 

WRITE  (2,82)  PLOTXY 

87  CALL  ELTIME(2,  4) 

99  RETURN 

END 
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SUBROUTINE  QSET (F,Y,X,DER,N) 


I 


20 


REV  III. 3  10/01 

IMPLICIT  REAL»8 (A-H.O-Z) 

DIMENSION  F(5,3,80) ,Y(5,3,80) ,X(3,80) ,DER(3,80) 

DIMENSION  Tl(3) ,T2(3) ,T3(3) ,T4(3) 

DO  20  1*1,  N 

EI=DSQRT( 1 .DO  -X( 1 , I) **2-X(2 , I) »«2-X(3 , I) »«2) 

E1D=- (X( 1 , I) *DER( 1 , I ) +X(2 , I ) *DER(2 , I) +X(3 , I) *DER(3 , I) ) /El 
E2=DSQRT(1.D0-Y(1,1.I)»«2-Y(1,2,I)»*2-Y(1,3,I)*«2) 

E2D=- (Y( 1,1,I)»Y(2,1,I)+Y(1,2,I)*Y(2,2,I)+Y(1,3,I)*Y(2,3,I)) /E2 
UHB=X ( 1,I)*F(3,1,I)+X(2,I)*F(3,2,I)+X(3,I)*F(3,3,I) 

UHC=X( 1 , I) *F(4 , 1 , I) +X(2 , I) »F(4 , 2 , I) +X(3 , I) *F(4 ,3 , I) 

UDB=DER( 1 , I) «F (3 , 1 , I) +DER(2 , I) »F (3 , 2 , I) +DER(3 ,I)*F(3,3,I) 
UDD=DER( 1 , I) *»2+DER(2 , I) «»2+DER(3 , I) «»2 
EB= (E1D«*2+UDD+UHB) /El 

EC  =  ( 1 . 5« (UDB-E1D«EB) ♦UHC+F (5 , I , I) * (E1D»«2+UDD) ) /El 

T1(1)=X(2,I)«F(3,3,I)-X(3,I)*F(3,2,I) 

T2 ( 1 ) =X(2 , I ) »F (4 , 3 , I ) -X(3 , I ) *F (4 , 2 , I) 
T3(1)=X(2,I)«Y(1.3,I)-X(3,I)«Y(1,2,I) 

T4 ( 1 ) =X(2 , I ) »Y(2 , 3 , I ) -X(3 , I) »Y(2 , 2 , I) 
T1(2)=X(3,I)«F(3,1,I)-X(1,I)»F(3,3,I) 
T2(2)=X(3,I)*F(4,1,I)-X(1,I)*F(4,3,I) 

T3 (2) *X (3,1) *Y (1,1,1) -X (1,1) *Y (1,3,1) 

T4 (2) =X(3 , I) »Y(2 , 1 , I) -X( 1 , I) »Y(2 , 3 , I) 
T1(3)=X(1,I)«F(3,2,I)-X(2,I)»F(3,1,I) 
T2(3)=X(1,I)*F(4,2,I)-X(2,I)«F(4,1,I) 

T3(3) =X( 1 . I) *Y( 1 .2, I) -X(2 , I) «Y( 1 . 1 , I) 

T4 (3) =X( 1 , I ) »Y(2 , 2 , I ) -X(2 , I ) «Y(2 , 1 , I ) 

DO  20  J=1 ,3 

F(3,J,I)*E1*F(3,J,I)-T1(J) +EB*X(0 ,1) 

F(4,J,I)=E1»F(4,J,I)-T2(J) +EC*X( J , I) 

Y(3,J,I)=E1»Y(1 , J , I) -T3 ( J) -E2»X( J ,1) 

Y(4,J,I)SE1*Y(2,J,I) -T4 (J) -E2D*X(J, I) 

RETURN 

END 
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SUBROUTINE  QUAT(ANG.Q) 
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COMPUTES  QUATERNIONS  FROM  TAW,  PITCH,  ROLL 
IMPLICIT  REAL  «8(A-H.0-Z) 

DIMENSION  ANG(3) ,Q(4) ,R(4) ,T(3) 
COMMON/CSSNTS/  PI .RADIAN, G, THIRD, EPS(24) , 

»  UNITL,UNITM,UNITT,QRAVTY(3) 

A  =  0 . 5* ANG( 1) "RADIAN 
Q  ( 1 )  =  DCOS(A) 

Q(2)  =  0.0 
Q  (3)  =  0.0 
Q(4)  =  DSIN(A) 

K  =  3 

DO  10  I  =  2,3 
A  =  0. 5«ANG( I ) "RADIAN 


R( 1)  =  DCOS(A) 

R(2)  =  0.0 
R(3)  =  0.0 
R(4)  =  0.0 
R(K)  =  DS1N(A) 

DOT  =  Q ( 2 ) * R ( 2 )  ♦  Q(3)»Rt3)  ♦  Q(4)»B(4) 
CALL  CROSS (Q(2) ,R(2) ,T) 

DO  5  J  =  2,4 

5  Q ( J)  =  Q( 1) *R(J)  +  R(1)*Q(J)  ♦  T(J-l) 

Q ( 1 )  *  Q ( 1) *R(1)  -  DOT 
10  K  =  2 

SUM  =  DSQRT (Q ( 1) »»2  ♦  Q(2)»»2  ♦  Q(3)«»2  ♦ 
DO  12  I  =  1,4 
12  Q ( I )  =  Q(I) /SUM 
RETURN 
END 
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DOUBLE  PRECISION  FUNCTION  RCBT (A, PL ,Z , IP)  RCRT 

REV  03  07/19/73RCRT 

COMPUTES  THE  RADIUS  OF  CURVATURE  AT  POINT  Z  OF  ELLIPSOID  A  RCRT 

IN  THE  PLANE  PL (I, IP)  WHERE  RCRT 

RCRT 

A.  3X3  MATRIX  DEFINING  ELLIPSOID.  RCRT 

PL:  4X3  MATRIX  CONTAINING  THREE  ORTHONORMAL  VECTORS.  RCRT 

Z:  3  COORDINATES  OF  POINT  ON  THE  ELLIPSOID  RCRT 

AS  MEASURED  FROM  CENTER  OF  ELLIPSOID  RCRT 

IP:  IDENTIFIES  THE  NORMAL  VECTOR  OF  PLANE  IN  WHICH  THE  RCRT 

RADIUS  OF  CURVATURE  IS  DESIRED.  RCRT 

RCRT 

IMPLICIT  REAL«8  (A-H.O-Z)  RCRT 

DIMENSION  A(3,3) ,PL(4.3) , Z ( 3 ) ,T(5)  RCRT 

DO  10  1=1,5  RCRT 

10  T ( I )  =  0.0  RCRT 

M  =  IP+1  RCRT 

N  =  IP+2  RCRT 

IFIM. GT.3)  M  =  M-3  RCRT 

IFIN. GT.3)  N  =  N-3  RCRT 

DO  30  1=1,3  RCRT 

51  =  0.  RCRT 

52  =  0.  RCRT 

DO  20  J=1 ,3  RCRT 

SI  =  S1+A(I,J) *PL (J ,M)  RCRT 

20  S2  =  S2+A(I,J)*PL(J,N)  RCBT 

T ( 1 )  =  T( 1 ) +S1*Z (I )  RCRT 

T(2)  =  T(2)*S2«Z(I)  RCRT 

T (3)  =  T ( 3 ) *S1*PL(I , M)  RCRT 

T(4)  =  T(4)+S2»PL(I ,N)  RCRT 

30  T (5)  =  T(5)+S1»PL(I,N)  RCRT 

W  =  DSQRT (T(l)*»2+T(2)»»2)  RCRT 

T(l)  =  T(l)/W  RCRT 

T(2)  =  T(2)/W  RCRT 

RCRT  =  W/(T(3)»T(2)«»2-2.0»T(1)*T(2)»T(5)+T(4)*T(1)*«2)  RCRT 

IF (RCRT. LT. 0.0)  RCRT  =  -RCRT  RCRT 

RETURN  RCRT 

END  RCRT 


SUBROUTINE  ROT  (A.L.TH) 
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REV  IV 


COMPUTES  ROTATION  MATRIX  A  FOR  ANGLE  TH 
ABOUT  X, Y  OR  Z  AXIS  AS  L  =  1,2,  OR  3. 


ARGUMENTS : 

A:  3X3  ROTATION  MATRIX  TO  BE  COMPUTED. 

L:  1.2  OR  3  TO  ROTATE  ABOUT  X.Y  OB  Z  AXIS. 
TH:  ANGLE  OF  ROTATION  IN  RADIANS. 


IMPLICIT  REAL *8  (A-H.O-Z) 

DIMENSION  A(3,3) 

COMMON/CNSNTS/  PI , RADIAN, G, THIRD, EPS(24) , 

*  UNITL.UNITM.UNITT ,GRAVTY(3) .TWOPI 


C=DCOS (TH) 
S=DSIN(TH) 
IF  CDABS(C) 


IF  CDABS(C)  . LT.EPSC8) )  C=0.0 
IF  (DABS(S) . LT.EPS(S) )  S=0.0 
ONE  =  1.0 

IF  ( 1. O-DABS (C) .LT. EPS (8))  C  =  DSIGN(ONE.C) 
IF  ( 1. O-DABS (S) .LT. EPS (8))  S  *  DSIGN(ONE.S) 
IF  (L.EQ.2)  S  =  -S 
DO  30  1=1,3 
IF(I.EQ.3)G0  TO  20 


DO  10  J=I , 2 
A ( I , J+l) =0.0 
A  (J+ 1 , 1) =0. 0 
IF(I+J+L.NE.5)G0  TO  10 
A ( I , J+l) =S 
A(J+1 ,I)=-S 
10  CONTINUE 
20  A(I . I) =  C 

IF(I.EQ.L)A(I,I)=1.0 
30  CONTINUE 
RETURN 
END 
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SUBROUTINE  ROTATE  ROTATE 

REV  IV  02/20/87HYPER 

THE  PURPOSE  OF  THIS  ROUTINE  IS  TO  TRANSFORM  THOSE  VARIABLES  THAT  ROTATE 
HAVE  BEEN  SUPPLIED  IN  LOCAL  GEOMETRIC  COORDINATES  TO  PRINCIPAL  ROTATE 
AXES  COORDINATES  AS  INDICATED  BY  LPMI (I)  *  0  FOR  I  =  1  TO  NSEG.  ROTATE 


IMPLICIT  REAL *8  (A-H.O-Z) 

COMMON/CONTRL/  TIME , NSEG , NJNT , NPL , NBLT , NBAG . NVEH , NGRND , 

*  NS , NQ , NSD , NFLX , NHRNSS , NWI NDF , NJNTF , NPRT ( 36 ) ,NPG 
COMMON/RSAVE/  XSG(3,20,3) .DPMI (3 , 3 , 30) , LPMI (30) . 

*  NSG(9) , MSG (20 ,9) ,MCG,MCGIN(24 .5) ,KREF(20,9) 
COMMON/ DESCRP/  PHI (3,30) ,W(30) ,RW(30) ,SR(4,60) ,HA(3,60) ,HB(3,60) 

*  RPHK3.30)  , HT(3 , 3 , 60)  ,SPRING(5 .90)  ,VISC(7,90)  , 

*  JNT(30) , IPIN (30) ,ISING(30) ,IGL0B(30) ,J0INTF(30) 
COMMON/CNTSRF/  PL(24,30) ,BELT(20,8) ,TPTS(6,8) ,BD(24,40) 


ROTATE 

ROTATE 

ROTATE 

ROTATE 

ROTATE 

PAGE 
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TTHKREF 

SLIP 

ROTATE 

ROTATE 

EDGE 


COMMON/ SGMNTS/  D(3,3,30) ,WMEG(3,30) ,WMEGD(3,30) .UK3.30) ,U2(3,30) .ROTATE 
»  SEGLP(3,30) ,SEQLV(3.30) ,SEGLA(3,30) ,NSYM(30)  ROTATE 

COMMON/ JBARTZ/  MNPL(  30) ,MNBLT(  8) ,MNSEG(  30) ,MNBAG(  6) ,  ROTATE 

*  MPL(3,5,30) ,MBLT(3,5,8) ,MSEG(3 , 5 , 30) ,MBAG(3, 10.6) ,  ROTATE 

»  NTPL(  5,30) ,NTBLT(  5,8) ,NTSEG(  5,30)  ROTATE 

COMMON/CSTRNT/  A13(3,3,24) ,A23(3,3,24) ,B31 (3,3,24) ,B32(3,3,24) ,  ROTATE 

*  HHT (3,3, 12) ,RK1(3,12) ,RK2(3,I2) ,QQ(3,12) ,TQQ(3,12) .ROTATE 

*  RQQ(3, 12) ,HQQ(3, 12) ,SQQ(12) ,CFQQ(12) ,  ROTATE 

»  KQ1(12) ,KQ2(12) ,KQTYPE(I2)  ROTATE 

COMMON/DAMPER/  APSDM(3,20) ,APSDN(3,20) ,ASD(5,20) ,MSDM(20) ,MSDN( 20) ROTATE 
COMMON/ WINDFR/  WTIME(30)  ,QFU(3,5) ,QFV(3,5) ,WF(3,30) ,IWIMD(30) ,  WINDOP 

»  MWSEG(7,30) , NFVSEG(6) ,NFVNT(5) , MOWSEG(30,30)  WINDOP 

COMMON/HRNESS/  BAR( 15 , 100) ,BB ( 100) .BBDOT ( 100) .PLOSS (2 , 100) ,  ROTATE 

»  XLONG(20) ,HTIME( 2) ,IBAR (5,100) ,NL( 2,100) .  ROTATE 

*  NPTSPB(20) , NPTPLY(20) ,NTHRNS(20) , NBLTPH(5)  ROTATE 

COMMON/TABLES/MXNTI , MXNTB , MXTB 1 , MXTB2 , NTI ( 50) ,NTAB(1250) , TAB (4500) WINDROT 
COMMON/CEULER/  IEULER(30) ,HIR(3 ,3, 90) , ANG(3 ,30) , ANGD(3 ,30) ,  FXHROT 

«  FE(3,30) ,TQE(3,30) ,CONST(5,30)  FXHROT 

COMMON/TEMPVS/  T1 (3) ,T3(3,3) ,LBD(40) ,T2(3) ,T4(3,3)  FXHROT 

ROTATE 

TRANSFORM  DIRECTION  COSINE  MATRICEES  D  FROM  INPUT  CARDS  G.3.  ROTATE 

ROTATE 

LTEST  =  0  ROTATE 

DO  20  J= 1 ,30  ROTATE 

IF  (J.GT.NSEG)  LPMI (J)  =  0  ROTATE 

IF  (LPMI (J) .EQ.O)  GO  TO  20  ROTATE 

LTEST  =  1  ROTATE 

DO  12  1=1,3  ROTATE 

T1(I)  =  WMEG(I.J)  ROTATE 

DO  12  K= 1 , 3  ROTATE 

12  T3(I ,K)  =  D(I ,K, J)  ROTATE 

CALL  MAT33  (DPMI ( 1 . 1 . J) ,T3 ,D ( 1 , 1 , J) )  ROTATE 

CALL  MAT31  (DPMI ( 1 , 1 , J) ,T1 . WMEG( 1 , J) )  ROTATE 

20  CONTINUE  ROTATE 

IF  (LTEST. EQ.O)  GO  TO  99  ROTATE 


ROTATE 


TRANSFORM  SR.HT  AND  HB  FROM  INPUT  CARDS  B.3. 

ROTATE 

ROTATE 

IF  (NJNT.LE.O)  GO  TO  31 

ROTATE 

DO  30  J= 1 ,NJNT 

ROTATE 

I  =  IABS (JNT (J) ) 

ROTATE 

M  =  2 

SLIP 

IF  (IABS(IPIN(J)) -GT.4)  M  =  3 

SLIP 

DO  24  K=1 ,2 

ROTATE 

IF  (I.EQ.O  .OR.  LPMI(I) .EQ.O)  GO  TO  24 

ROTATE 

IJ  =  2»J-2+K 

ROTATE 

DO  22  LI=1 ,3 

ROTATE 

Tl(LI)  =  SR(LI.IJ) 

ROTATE 

T2 (LI )  =  HB(LI,IJ) 

FXHROT 

DO  22  L J  = 1 , 3 

ROTATE 

T4 (LI ,LJ)  =  HIR(LI,LJ,IJ+30) 

FXHROT 

22 

T3 (LI ,LJ)  =  HT (LI ,LJ , I J) 

ROTATE 

CALL  MAT31  (DPMI ( 1 . 1 , I) ,T1 ,SR ( 1 . I J) ) 

ROTATE 

CALL  MAT31  (DPMI ( 1 . 1 . I) ,T2 ,HB( 1 , I J) ) 

FXHROT 

CALL  MAT33  (DPMI ( 1 . 1 , I) ,T3 ,HT( 1 , 1 , IJ) ) 

ROTATE 

CALL  MAT33  (DPMI ( 1 , 1 , I ) ,T4 ,HIR( 1 , 1 . I J+30) ) 

FXHROT 

24 

I  =  J+ 1 

ROTATE 

30 

CONTINUE 

ROTATE 

ROTATE 

TRANSFORM  RK1.RK2  FROM  INPUT  CARDS  D.6. 

ROTATE 

ROTATE 

31 

IF  (NQ.LE.O)  GO  TO  41 

ROTATE 

K5  =  0 

ROTATE 

DO  40  K=1,NQ 

ROTATE 

IF  (K5.EQ.1)  GO  TO  39 

ROTATE 

KSEG  =  KQ1(K) 

ROTATE 

IF  (LPMI (KSEG) .EQ.O)  GO  TO  36 

ROTATE 

DO  35  1=1.3 

ROTATE 

35 

Tl(I)  =  RKKI.K) 

ROTATE 

CALL  MAT31  (DPMI ( 1 . 1 .KSEG) ,T1 ,RK1 ( 1 ,K) ) 

ROTATE 

36 

KSEG  =  KQ2 (K) 

ROTATE 

IF  (LPMI (KSEG) .EQ.O)  GO  TO  40 

ROTATE 

DO  37  1=1,3 

ROTATE 

37 

T1(I)  =  RK2(I,K) 

ROTATE 

CALL  MAT31  (DPMI ( 1 . 1 .KSEG) ,T1 ,RK2 ( 1 ,K) ) 

ROTATE 

39 

IF  (KQTYPE(K) .EQ.5)  K5  =  1-K5 

ROTATE 

40 

CONTINUE 

ROTATE 

ROTATE 

TRANSFORM  APSDM, APSDN  FROM  INPUT  CARDS  D.8. 

ROTATE 

ROTATE 

41 

IF  (NSD.LE.O)  GO  TO  151 

FIXROT 

DO  50  J=  1 ,  NSD 

ROTATE 

KSEG  =  MSDM(J) 

ROTATE 

IF  (LPMI (KSEG) .EQ.O)  GO  TO  44 

ROTATE 

DO  43  1=1,3 

ROTATE 

o  o  o  o  ooo  ooo 


I 

t 

► 

\ 


43  T1(I)  =  APSDM(I.J) 

CALL  MAT31  (DPMI (1 , 1 ,KSEO) ,T1 ,APSDM(1 ,J) ) 

44  KSEQ  =  MSDN(J) 

IF  (LPMKKSEQ)  .EQ.O)  GO  TO  50 
DO  45  1=1,3 

45  Tl(I)  =  APSDM(I.J) 

CALL  MAT31  (DPMI (1,1 ,KSEG) , T 1 ,APSDN(1 , J) ) 

50  CONTINUE 

TRANSFORM  QFU  AND  QFV  FROM  INPUT  CARDS  D.9. 

151  NFORCE  =  NFVSEG(6) 

IF  (NFORCE. LE.O)  GO  TO  100 
DO  152  J=l, NFORCE 
KSEG  =  IABS (NFVSEG(J) ) 

IF  (LPMI (KSEG) .EQ.O)  GO  TO  152 
DO  143  1=1,3 
T1(I)  =  QFU(I,J) 

143  T2 (I )  =  QFV(I,J5 

CALL  MAT31  (DPMI ( 1 , 1 , KSEG) ,T1 ,QFU( 1 ,J) ) 

CALL  MAT31  (DPMI (1 . 1 .KSEG) ,T2,QFV(1 ,J) ) 

152  CONTINUE 

ROTATE  WIND  FORCE  FUNCTIONS 

100  IF  (NWINDF.EQ.O)  GOTO  51 
DO  101  1=1 ,NSEG 

IF  (MWSEG(l.I) .EQ.O)  GOTO  101 
NT  =  MWSEG(5 , I ) 

DO  102  J=1,I-1 

IF  (NT.EQ.MWSEG(5 , J) )  GOTO  101 

102  CONTINUE 

KT  =  NTI  (NT) 

RK  =  TAB(KT) 

IF  (RK.NE.O)  GOTO  101 
NSR  =  I DINT (TAB (KT+4) ) 

IF  (NSR. EQ.O  .OR.  LPMI (NSR) . EQ. 0)  GOTO  101 
NENTRY  =  TAB (KT+5) 

K1  =  KT+6 

K2  =  4*NENTRY+KT*2 
DO  103  K=K1 ,K2 , 4 
DO  104  J=I ,3 
104  T 1 ( J )  =  TAB(K+J) 

103  CALL  MAT31 (DPMI (1,1, NSR) ,T1 ,TAB(K+ 1) ) 

101  CONTINUE 

CHECK  PLANE  AND  ELLIPSOID  ASSIGNMENTS  ON  INPUT  CARDS  F.l. 
TRANSFORM  PLANE  ARRAYS  SET  UP  FROM  INPUT  CARD  D.l. 

51  DO  52  J= 1 , 40 
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ROTATE 
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WINDROT 

WINDROT  [ 

WINDROT 

ROTATE  | 

ROTATE  j 

ROTATE  ; 

ROTATE  , 

ROTATE 


LBD(J)  =  0  BOTATE 

52  IF  (J.LE.MSEG)  LBD(J)  =  J  BOTATE 

IF  (NPL.LE.O)  GO  TO  61  BOTATE 

DO  60  J=1 ,HPL  BOTATE 

IF  (MNPL(J)  . EQ.O)  GO  TO  60  BOTATE 

LPL  =  0  BOTATE 

KPL  =  MNPL(J)  BOTATE 

DO  58  1=1, KPL  BOTATE 

Ml  =  MPL  (1,1  ,J)  BOTATE 

M2  =  MPL  (2 , I , J)  BOTATE 

M3  =  MPL  (3.I.J)  BOTATE 

IF  (LPL.EQ.M1  .OB.  LPL. EQ.O)  GO  TO  54  BOTATE 

WRITE  (6,53)  J, Ml, LPL  BOTATE 

53  FOBMAT ( ’ 0  INPUT  EBROB  HAS  BEEN  DETECTED  IN  SUBROUTINE  ROTATE.’/  ROTATE 

«  ’  PLANE  NO.', 13,'  HAS  BEEN  ASSIGNED  TO  BOTH  SEGMENTS  NO. ’.ROTATE 

«  13,’  AND  NO. ’,13,’.’/*  PROGRAM  IS  BEING  TERMINATED.')  ROTATE 

STOP  43  BOTATE 

54  LPL  =  Ml  ROTATE 

IF  (LBD(M3) . EQ.M2  .OR.  LBD(M3) .EQ.O)  GO  TO  55  ROTATE 

WRITE  (6,68)  M3,M2,LBD(M3)  ROTATE 

STOP  44  BOTATE 

55  LBD (M3)  =  M2  ROTATE 

56  CONTINUE  ROTATE 

IF  (LPMI  (LPL) .EQ.O)  GO  TO  60  ROTATE 

L  =  1  EDGE 

DO  59  K=1 ,6  EDGE 

IF( (K.EQ.3) .OR. (K.EQ.6))  L  =  L-l  EDGE 

IF ( (K.EQ. 4) .OR. (K.EQ.5) )  L  =  L+l  EDGE 

DO  58  1=1,3  BOTATE 

THI)  =  PL(L.J)  EDGE 

58  L=L+ 1  EDGE 

CALL  MAT31  (DPMI ( I , 1 ,LPL) ,T1 ,PL(L-3 , J) )  EDGE 

59  L=L+ 1  EDGE 

60  CONTINUE  ROTATE 

ROTATE 

CHECK  ELLIPSOID  ASSIGNMENTS  ON  INPUT  CARDS  F.2.  ROTATE 

TRANSFORM  BELT(L.J)  FOR  L=l,9  FBOM  INPUT  CARDS  D.3.  ROTATE 

ROTATE 

61  IF  (NBLT.LE.O)  GO  TO  66  ROTATE 

DO  65  J= 1 , NBLT  ROTATE 

IF  (MNBLT(J) .EQ.O)  GO  TO  65  BOTATE 

KELT  =  MNBLT(J)  BOTATE 

DO  62  1=1, KBLT  ROTATE 

Ml  =  MBLT ( 1 , I , J)  BOTATE 

M2  =  MBLT (2, I, J)  ROTATE 

M3  =  MBLT (3, I, J)  ROTATE 

IF  (LBD (M3) .EQ. M2  .OR.  LBD (M3) .EQ . 0)  GO  TO  62  ROTATE 

WRITE  (6,68)  M3 ,M2 .LBD (M3)  BOTATE 

STOP  45  BOTATE 

62  LBD (M3)  =  M2  ROTATE 


IF  (LPMI (Ml) .EQ.O)  GO  TO  63  ROTATE 

DO  57  1=1,3  ROTATE 

T3 ( 1 , 1 )  =  BELT (I  ,J)  ROTATE 

57  T3(I ,2)  =  BELT (I +3, J)  ROTATE 

CALL  MAT31  (DPMI (1.1.M1) ,T3(1,1) , BELT ( 1 . J) )  ROTATE 

CALL  MAT31  (DPMI (1 , 1 .Ml) ,T3(1 ,2) ,BELT(4,J) )  ROTATE 

63  IF  (LPMI (M2) .EQ.O)  GO  TO  65  ROTATE 

DO  64  1=1,3  ROTATE 

64  T3 ( 1 ,3)  =  BELT (1+6, J)  ROTATE 

CALL  MAT31  (DPMI ( 1 , 1 ,M2) ,T3 ( 1 ,3) .BELT (7 , J) )  ROTATE 

65  CONTINUE  ROTATE 

ROTATE 

CHECK  ELLIPSOID  ASSIGNMENTS  ON  INPUT  CARDS  F.3.  ROTATE 

ROTATE 

66  DO  70  J= 1 , NSEG  ROTATE 

IF  (MNSFG(J) .EQ.O)  GO  TO  70  ROTATE 

KSEG  =  MNSEG(J)  ROTATE 

DO  69  1=1, KSEG  ROTATE 

Ml  =  MSEG(1,I.J)  ROTATE 

M2  =  MSEG(2 , I , J)  ROTATE 

M3  =  MSEG(3 , I , J)  ROTATE 

IF  (LBD(Ml) .EQ.J  .OR.  LBD(Ml) .EQ.O)  GO  TO  67  ROTATE 

WRITE  (6,68)  Ml.J.LBD(Ml)  ROTATE 

STOP  46  ROTATE 

67  LBD(Ml)  =  J  ROTATE 

IF  (LBD(M3) . EQ.M2  .OR.  LBD(M3) .EQ.O)  GO  TO  69  ROTATE 

WRITE  (6,68)  M3 ,M2 ,LBD(M3)  ROTATE 

68  FORMAT (’0  INPUT  ERROR  HAS  BEEN  DETECTED  IN  SUBROUTINE  ROTATE.’/  ROTATE 

*  ’  ELLIPSOID  NO.  M3,’  HAS  BEEN  ASSIGNED  TO  BOTH  SEGMENTS  NO.  ’  .ROTATE 

«  13 , ’  AND  NO. ’ , 13 . ’ . ’ / ’  PROGRAM  IS  BEING  TERMINATED. ’ )  ROTATE 

STOP  47  ROTATE 

69  LBD (M3)  =  M2  ROTATE 

70  CONTINUE  ROTATE 

ROTATE 

CHECK  ELLIPSOID  ASSIGNMENTS  ON  INPUT  CARDS  F.6.  ROTATE 

ROTATE 

IF  (NBAG.EQ.O)  GO  TO  174  TGM0D8 

DO  73  J  = 1 , NBAG  ROTATE 

IF  (MNBAG(J) .EQ.O)  GO  TO  73  ROTATE 

KBAG  =  MNBAG(J)  ROTATE 

DO  72  1=1, KB AG  ROTATE 

M2  =  MBAG(2 , I , J)  ROTATE 

M3  =  MBAG ( 3 , I , J )  ROTATE 

IF  (LBD (M3) .EQ. M2  .OR.  LBD(M3) .EQ.O)  GO  TO  72  ROTATE 

WRITE  (6,68)  M3, M2, LBD (M3)  ROTATE 

STOP  50  ROTATE 

72  LBD (M3)  =  M2  ROTATE 

73  CONTINUE  ROTATE 

TGM0D8 

CHECK  ELLIPSOID  ASSIGNMENTS  ON  INPUT  CARDS  F.7.  TGM0D8 


c  TGM0D8 

174  IF(NWINDF.EQ.O)  GO  TO  74  TGM0D8 

DO  175  J=1 , HSEG  TGM0D8 

Ml  =  IABS(MWSEG(1,J))  TGM0D8 

IF (Ml. EQ.O)  GO  TO  175  TGM0D8 

M2  =  MWSEG(2 , J)  TGM0D8 

IF(LBD(M2) . EQ.M1 .0R.LBD(M2) . EQ.O)  GOTO  172  TGM0D8 

WRITE (6 ,68)  M2 ,M1 ,LBD (M2)  TGM0D8 

STOP  48  TGM0D8 

172  LBD(M2)  =  Ml  TGMOD8 

175  CONTINUE  TGM0D8 

C  ROTATE 

C  CHECK  ELLIPSOID  ASSIGNMENTS  ON  INPUT  CARDS  F.8.  ROTATE 

C  TRANSFORM  BAR(L.K)  FOR  L=4,12  FROM  INPUT  CARDS  F.8.D.  ROTATE 

C  ROTATE 

74  IF  (NHRNSS.EQ.O)  GO  TO  81  ROTATE 

J1  =  1  ROTATE 

K 1  =  1  ROTATE 

DO  80  11=1, NHRNSS  ROTATE 

IF  (NBLTPH(II) . LE.O)  GO  TO  80  ROTATE 

J2  =  J1  +  NBLTPH (II)  -  1  ROTATE 

DO  79  JJ=J1 , J2  ROTATE 

IF  (NPTSPB(JJ) .LE.O)  GO  TO  79  ROTATE 

K2  =  K1  +  NPTSPB(JJ)  -  1  ROTATE 

DO  78  K=Kl ,K2  ROTATE 

M2  =  M0D(IBAR(1,K) ,100)  ROTATE 

M3  =  IBAR(2,K)  ROTATE 

IF  (M3. EQ.O)  GO  TO  88  BUTLER 1 

IF  (LBD(M3) .EQ.M2  .OR.  LBD(M3) .EQ.O)  GO  TO  75  ROTATE 

WRITE  (6,88)  M3,1I2,LBD(M3)  ROTATE 

STOP  51  ROTATE 

75  LBD (M3)  =  M2  ROTATE 

88  IF  (LPMKM2)  .EQ.O)  GO  TO  78  BUTLER  1 

DO  77  J=3,9,3  ROTATE 

DO  76  1=1,3  ROTATE 

IJ  =  I+J  ROTATE 

76  T 1 ( I )  =  BAR(IJ.K)  ROTATE 

77  CALL  MAT31  (DPMI  (1 , 1 ,M2) ,T1 ,BAB(J+1 ,K) )  ROTATE 

78  CONTINUE  ROTATE 

K1  =  K2+ 1  ROTATE 

79  CONTINUE  ROTATE 

Jl  =  J2+1  ROTATE 

80  CONTINUE  ROTATE 

C  ROTATE 

C  TRANSFORM  DATA  IN  BD  ARRAYS  FOB  ELLIPSOIDS  THAT  HAVE  BEEN  ASSIGNEDROTATE 
C  ROTATE 

81  DO  90  J= 1 ,40  ROTATE 

IF  (LBD(J) .EQ.O)  GO  TO  90  ROTATE 

KSEG  =  LBD(J)  ROTATE 

IF  (LPMI (KSEG) .EQ.O)  GO  TO  90  ROTATE 
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L  =  4 

IF  (BD(l.J).LT.O.O)  L  =  5 
M  *  8 

DO  82  1=1,3 


Till)  =  BD(L.J) 
L  =  L  ♦  1 


DO  82  K  =  1,3 
T3 (K , I)  =  BD(M,J) 

82  M  =  M  +  1 

CALL  MAT31  (DPMI ( 1 , 1 ,KSEG) ,T1 ,BD (L-3 , J) ) 

IF  (BD( 1 , J) . QT.O.O)  GO  TO  84 

CALL  MAT33  (DPMI ( 1 , 1 ,KSEG) ,T3 ,BD (8 , J) ) 

GO  TO  90 

84  CALL  D0TT33  (BD(  7 , J) .DPMI ( 1 . 1 ,KSEG) ,T3) 
CALL  MAT33  (DPMI ( 1 , 1 ,KSEG) ,T3 ,BD(  7,J)) 
CALL  D0TT33  (BD(16,J) .DPMI (1,1 ,KSEG) ,T3) 
CALL  MAT33  (DPMI ( 1 , 1 ,KSEG) ,T3 ,BD( 10 , J) ) 


90  CONTINUE 
99  RETURN 
END 
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SUBROUTINE  RSTART (IF, IT)  RSTART 

REV  IV  07/24/86SLIP 

THE  FIVE  FUNCTIONS  OF  SUBROUTINE  RSTART  ARE:  RSTART 

1.  READ  INPUT  &  INITIALIZATION  RECORD  FROM  OLD  RESTART  TAPE.  RSTART 

2.  WRITE  INPUT  &  INITIALIZATION  RECORD  ONTO  NEW  RESTART  TAPE.  RSTART 

3.  READ  TIME  POINT  RECORD  FROM  OLD  RESTART  TAPE.  RSTART 

4.  READ  NEW  INPUT  DATA  FROM  INPUT  STREAM  FOR  RESTART.  RSTART 

5.  WRITE  TIME  POINT  RECORD  ONTO  NEW  RESTART  TAPE.  RSTART 

RSTART 

IMPLICIT  REAL»8(A-H,0-Z)  RSTART 

RSTART 

ALL  LABELED  COMMON  BLOCKS  ARE  INCLUDED  HERE  RSTART 

TO  GIVE  A  COMPLETE  SET  FOR  REFERENCE  RSTART 

RSTART 

COMMON/CONTRL/  TIME , NSEG , NJNT , NPL , NBLT , NBAS , NVEH , NGRND ,  RSTART 

*  NS , NQ , NSD , NFLX , NHRNSS , NWI NDF , NJNTF , NPRT ( 36 ) , NPG  PAGE 

DIMENSION  IC1 (51)  PAGE 

EQUIVALENCE  (ICI(l).NSEG)  RSTART 

RSTART 

COMMON/CNTSRF /  PL(24 ,30) ,BELT(20 ,8) ,TPTS (6 ,8) ,BD(24 ,40)  EDGE 

DIMENSION  RC2 ( 1888)  EDGE 

EQUIVALENCE  (RC2(1) ,PL(1 , 1) )  RSTART 

RSTART 

COMMON/ VPOSTN/  ZPLT(3) ,SPLT(3) ,AXV(3,6) ,VATAB(6,501 ,6) ,  VEHICL 

«  VT0(6) , VDT(6) , ?IMEV(6) , 0MEGV(6) , NVTAB(6) , INDXV(6)  RSTART 

DIMENSION  RC3(18084) , IC3 (12)  VEHICL 

EQUIVALENCE  (RC3 ( 1) ,ZPLT(1)) , (IC3(1) ,NVTAB(1) )  RSTART 

RSTART 

COMMON/ SGMNTS/  D(3,3,30) ,WMEG(3,30) ,WMEGD(3,30) ,U1(3,30) ,U2(3,30) .RSTART 

*  SEGLP(3,30) ,SEGLV(3,30) ,SEGLA(3,30) ,NS7M(30)  RSTART 

DIMENSION  RC4 (900)  RSTART 

EQUIVALENCE  (RC4 ( 1 ) ,D( 1 , 1 , 1) )  RSTART 

RSTART 

COMMON/CMATRX/  VI (3,30) ,V2(3,30) ,V3(3,12) ,B12(3,3,60) ,A22(3,3,60) .RSTART 
«  F(3,30) ,TQ(3,30) ,WJ(30) ,A11(3,3,30)  SLIP 

DIMENSION  RC5A(1296) ,RC5B(480)  SLIP 

EQUIVALENCE  (RC5A(1) ,V1 (1 , 1) ) , (RC5B(1) ,F(1 , 1) )  RSTART 

RSTART 

COMMON/ ABDATA/  ZDEP(3,5) ,DBR(3,3,5) ,DPVCTR(3,5) ,DEPL0Y(3,5) ,  RSTART 

»  ABO, 5)  ,B(9,4,5)  ,ZR(3,4,5)  ,BFB(3,4,5)  ,DRR(9,4,5)  ,  RSTART 

*  VBAGG(5) ,VSCS(5) ,SPRX(5) ,CK(5) ,CMASS(5) ,CYMIN(5) ,  RSTART 

»  CYM0UT(5) ,BAGPV(5) ,PD(5) ,VBAG(5) ,V0LBP(5) ,  RSTART 

«  PCYV(5) ,PCYMIN(5) , PVBAG(5) ,TV1 (3,4,5) ,TV2(3, 10,5) ,  RSTART 

»  SWITCH(5) ,PYM0UT(5) .SCALE (5) , PREVT,IFULL(6)  RSTART 

DIMENSION  RC6A(610) ,RC6B(271)  RSTART 

EQUIVALENCE  (RC6A(1) ,ZDEP(1 , 1) )  ,  (RC6B(1) .CYMIN(l))  RSTART 

RSTART 

COMMON/TITLES/  DATE(3) ,COMENT(40) ,VPSTTL(20) ,BDYTTL(5) ,  RSTART 

*  BLTTTL(5,8) ,PLTTL(5,30) ,BAGTTL(5,6) ,SEG(30) ,  RSTART 

»  J0INT(30) ,CGS(30) ,JS(30)  RSTART 


REAL  DATE , COMENT , VPSTTL , BDYTTL , BLTTTL , PLTTL , BAGTTL , SEG , JO I HT  RSTART 

LOGICAL* 1  CGS.JS  RSTART 

REAL  RC7 , RC7A . XDTE , XCMENT  RSTART 

DIMENSION  RC7(305) ,RC7A( 348) , XDTE (3) .XCMEHT (40)  RSTART 

EQUIVALENCE  (RC7(1) .VPSTTL(I) ) , (RC7A(1) .DATE(l) )  RSTART 

RSTART 

COMMON/CNSNTS/  PI , RADI AN . G , THIRD , EPS (24) ,  RSTART 

*  UNITL,UNITIi,UNITT,GRAVTY(3)  .TWOPI  TWOPI 

DIMENSION  RC8 (35)  TWOPI 

EQUIVALENCE  (RC8(1),PI)  RSTART 

RSTART 

COMMON / DESCRP /  PHI (3,30) ,W(30) ,RW(30) ,SR(4,60) ,HA(3,60) ,HB(3,60) ,  SLIP 

*  RPHI (3,30) ,HT (3 ,3 ,60) .SPRING (5 ,90) , VISC (7,90) ,  RSTART 

«  JNT(30) ,IPIN(30) ,ISING(30) ,IGLOB(30) ,J0INTF(30)  RSTART 

DIMENSION  RC9 (2460) , ICO (150)  SLIP 

EQUIVALENCE  (RC9 ( 1) ,PHI ( 1 . I) ) . ( ICO ( 1) , JNT ( I) )  RSTART 

RSTART 

COMMON/ JBARTZ/  MNPL(  30) ,MNBLT(  8) ,MNSEG(  30) ,MNBAG(  6) ,  RSTART 

*  MPL(3,5, 30) ,MBLT(3, 5,8) ,MSEG(3, 5,30) ,MBAG(3, 10,6) ,  RSTART 

»  NTPL (  5,30) .NTBLT (  5,8),NTSEG(  5,30)  RSTART 

DIMENSION  IC10 ( 1614)  RSTART 

EQUIVALENCE  (IC10(1) ,MNPL( I) )  RSTART 

RSTART 

COMMON/FORCES/ rSFi 7, 10) ,BSF(4,20) ,SSF(10,40) ,BAGSF(3,20) ,  NCFORC 

*  PRJNT (7,30), NPANEL ( 5 ) , NPSF . NBSF . NSSF . NBGSF  RSTART 

DIMENSION  RC1K1240)  .  IC1 1  (0)  NCFORC 

EQUIVALENCE  (RC1 I (1) , PSF( 1 , 1) ) , (IC1 1 ( 1) .NPANEL (1) )  RSTART 

RSTART 

COMMON/ INTEST/  SGTEST (3 ,4 ,30) .XTEST (3 , 120) ,SEGT( 120) ,REGT( 120)  RSTART 
REAL  SEGT  RSTART 

DIMENSION  RC12 (720)  RSTART 

EQUIVALENCE  (RC12(1) ,SGTEST(1 , 1 , 1) )  RSTART 

RSTART 

COMMON/CSTRNT/  A13 (3 . 3 , 24) ,A23(3,3,24) ,B31 (3,3,24) ,B32(3,3,24) ,  RSTART 
«  HHT (3,3,12) ,RK1 (3 , 12) ,RK2(3,12) ,QQ(3,12) ,TQQ(3,12) .RSTART 

«  RQQ(3, 12) ,HQQ(3, 12) ,SQQ(12) ,CFQQ(12) ,  RSTART 

»  KQ1 (12) ,KQ2 (12) .KQTYPE (12)  RSTART 

DIMENSION  RC13(72) ,IC13(36) ,RCI3A(1212) ,RC13H(348)  RSTART 

EQUIVALENCE  ( RC 13(1) ,RK 1(1,1)) , (IC13 ( 1) , KQ1 ( 1) ) ,  RSTART 

»  (RC13A(1) ,A13(1,1,1)) ,(RC13H(1) ,HHT(1,1,1))  RSTART 

RSTART 

COMMON/TABLES/MXNTI .MXNTB.MXTBl ,MXTB2 ,NTI (50) ,NTAB(1250) .TAB (4500) DIMENB 
DIMENSION  IC 1 4 (1304)  BUTLER2 

EQUIVALENCE  ( IC14 ( 1 ) .MXNTI)  RSTART 

RSTART 

C0MM0N/C0MAIN/VAR(240) ,DER(240) , DT , HO , HMAX , HMIN , RSTIME ,  RSTART 

«  I STEP , NSTEPS , NDINT , NEQ , IRSIN , IRSOUT  RSTART 

DIMENSION  RC15(485) . IC15 (6)  RSTART 

EQUIVALENCE  (RC15(I) ,VAR(1) ) , (IC15 ( 1) .ISTEP)  RSTART 

RSTART 


COMMON/CDINT/  UU (4) ,GH (3 , 4) ,  RSTART 

«  E(3,240) ,FF(5,240) ,GG(5,240) ,7(5,240) ,11(5,240) ,  RSTART 

«  H , HPRINT , HS , TPRINT , TSTART , ICNT , IDBL , IFLAQ  RSTART 

C  NOTE:  FF  REPLACES  F  FROM  SUBROUTINE  DINT.  RSTART 

DIMENSION  RCI6(5541) ,IC16(3)  RSTART 

EQUIVALENCE  (RC16 ( 1) ,UU( 1) ) . (IC16 ( 1) , ICNT)  RSTART 

C  17  RSTART 

COMMON/ DAMPER/  APSDM(3,20) ,APSDN(3,20) ,ASD(5.20) ,MSDM(20) ,MSDN( 20) RSTART 
DIMENSION  RC171220) . IC17 (40)  RSTART 

EQUIVALENCE  (RC17 ( 1) , APSDM( 1 . 1) > , ( IC17 ( 1) ,MSDM( 1) )  RSTART 

C  18  RSTART 

COMMON/CEULER/  IEULERC30) ,HIR(3 ,3 ,90) . ANG(3 ,30) , ANQD(3 .30) .  JDRIFT 

*  FE(3,30) ,TQE(3,30) ,C0NST(5,30)  JDRIFT 

DIMENSION  RC18 (1320)  JDRIFT 

EQUIVALENCE  ( RC 18(1) ,HIR(1 ,1,1))  RSTART 

C  19  RSTART 

COMMON/TEMPVI/  CREST ,TTI (3) ,R1I (3) ,R2I (3) ,JST0P(4,2,30)  RSTART 

DIMENSION  RC19( 10) ,IC19( 180)  RSTART 

EQUIVALENCE  ( RC 19(1) .CREST) , (IC19(1) ,JST0P(1 ,1,1))  RSTART 

C  20  RSTART 

COMMON/C YD ATA/  CYTD(5) ,CYPA<5) ,CYSP(5) ,CYT0(5) ,CYV0(5) ,CYCD(5) ,  RSTART 

*  CYK(5) ,CYR(5) ,CYAT(5) ,CYPV(5) ,CYCD0(5) ,CYA0(5) ,  RSTART 

*  CYPO (5) , CYSS (5) ,CYLO (5) ,CYC(5) ,CYRH00(5) ,CYVMAX(5) .RSTART 

*  CY0RFC(5) ,CYRH0(5) ,CYT(5) ,CYP(5) ,CYV(5)  RSTART 

DIMENSION  RC20A(95) ,RC20B(20)  RSTART 

EQUIVALENCE  (RC20A1 1) ,CYTD( 1) )  ,  (RC20B(1) .CYRHO(l) )  RSTART 

C  21  RSTART 

COMMON/RSAVE/  XSG(3 , 20 .3) .DPMI (3 ,3 ,30) ,LPMI (30) ,  ATBIII 

»  NSG(9) ,MSG(20,9) ,MCG,MCGIN(24 ,5) ,KREF(20,9)  TTHKREF 

DIMENSION  RC21 (450) , IC21 (520)  TTHKREF 

EQUIVALENCE  (RC21 ( 1) . XSG ( 1,1,1))  ,  (IC21 ( 1) ,LPMI ( 1) )  RSTART 

C  22  RSTART 

COMMON/FLXBLE/  HF (4 , 12 , 8) ,B42 (3 ,3 , 24) , V4 (3 ,8) ,NFLEX(3 ,8)  RSTART 

DIMENSION  RC22 (624) .IC22 (24)  RSTART 

EQUIVALENCE  (RC22(1) ,HF( 1.1,1))  .  (IC22 ( 1) ,NFLEX(1 , 1) )  RSTART 

C  23  RSTART 

COMMON/HRNESS/  BAR( 15 . 100) ,BB ( 100) ,BBDOT( 100) .PLOSS (2 , 100) ,  RSTART 

«  XL0NG(20) ,HTIME(2) , IBAR(5, 100) ,NL(2, 100) ,  RSTART 

»  NPTSPB(20) ,NPTPLY(20) ,NTHRNS(20) ,NBLTPH(5)  RSTART 

DIMENSION  RC23(1922) ,1023(765)  RSTART 

EQUIVALENCE  (RC23(1) ,BAR(1 , I) ) , (IC23(1) , IBAR(1 , 1) )  RSTART 

C  24  RSTART 

COMMON/ WINDFR/  WTIMEUO)  ,QFU(3,5)  ,QFV(3,5)  ,WF(3,30)  ,IWIND(30)  ,  WINDOP 

»  MWSEG(7,30) ,NFVSEG(6) ,NFVNT(5) , M0WSEG(30,30)  WINDOP 

DIMENSION  RC24(150) ,1024(1151)  WINDOP 

EQUIVALENCE  (RC24 (1) , WTIME ( 1) ) , (IC24 ( 1) , IWIND( 1) )  RSTART 

C  RSTART 

REAL  A0LD4 , AA0LD4  RSTART 

DIMENSION  C0MM0N(24) ,INDEX(3)  RSTART 

DATA  COMMON  /8HC0NTRL  , 8HCNTSRF  , 8HVP0STN  , 8HSGMNTS  ,  RSTART 


L 


8HCMATRX  , 8HABDATA  , 8HTITLES  , 8HCNSNTS  . 

8HDESCRP  , 8HJBARTZ  , 8HF0RCES  , 8HINTEST  . 

8HCSTRNT  , 8HTABLES  , 8HC0MAIN  , 8HCDINT 

8HDAMPER  , 8HCEULER  ,8HTEMPVI  , 8HCYDATA  . 

8HRSAVE  , 8HFLXBLE  , 8HHRNESS  , 8HWINDFR  / 

DATA  BLANK/8H  / 

CALL  ELTIME(1 ,25) 

GOTO  (100,200,300.400,500) .IF 

1.  READ  INPUT  &  INITIALIZATION  RECORD  FROM  OLD  RESTART  TAPE. 


100  READ  (IT)  IC1,  PL,  RC3,  IC3,  NSYM,  RC6A,  I FULL,  XDTE,  XCMENT, 

»  RC7 ,  CGS,  JS,  RC8.  RC9,  IC9,  IC10,  NPANEL ,  SGTEST, 

»  RC13,  IC13 ,  IC14,  DT.  HO,  HMAX,  HMIN,  NSTEPS,  NDINT , 

»  RC17 ,  IC17 ,  I EULER,  IC19,  RC20A,  RC21,  IC21,  HF,  IC22, 

*  RC23 ,  IC23,  RC24,  IC24 

WRITE  (6,101)  IT, XDTE, XCMENT 

101  FORMAT ( ’ 0  INPUT  DATA  HAS  BEEN  READ  IN  FROM  UNIT  NO. ’,14// 

»  10X.3A4//10X, 20A4/ 10X, 20A4) 

GO  TO  999 

2.  WRITE  INPUT  &  INITIALIZATION  RECORD  ONTO  NEW  RESTART  TAPE. 

200  WRITE  (IT)  IC1,  PL,  RC3 ,  IC3,  NSYM,  RC6A,  I FULL,  DATE,  COMENT, 

«  RC7 ,  CGS,  JS,  RC8,  RC9,  IC9,  IC10,  NPANEL,  SGTEST, 

*  RC13,  IC13 ,  IC14 ,  DT,  HO,  HMAX,  HMIN,  NSTEPS,  NDINT, 

»  RC17 ,  IC17 ,  I EULER,  IC19,  RC20A,  RC21,  IC21,  HF,  IC22, 

*  RC23,  IC23,  RC24,  IC24 

GO  TO  999 

3.  READ  TIME  POINT  RECORD  FROM  OLD  RESTART  TAPE. 

300  READ  (IT)  TIME,  BELT,  TPTS ,  BD,  RC4,  RC5B,  RC6B,  I FULL,  IPIN, 

*  RC1 1 ,  IC11.  XTEST,  SEGT,  REGT,  RC13H,  KQTYPE ,  TAB. 

«  VAR.  DER.  NEQ,  RC16,  IC16,  I EULER,  RC18,  IC19,  RC20B, 

*  RC21 ,  IC21,  V4 ,  RC23,  NL ,  NPTPLY,  WTIME,  IWIND 
CALL  OUTPUT ( 1 ) 

GO  TO  999 

5.  WRITE  TIME  POINT  RECORD  ONTO  NEW  RESTART  TAPE. 

500  WRITE  (IT)  TIME.  BELT.  TPTS,  BD,  RC4,  RC5B,  RC6B,  I FULL,  IPIN, 

*  RC11,  IC11,  XTEST,  SEGT,  REGT,  RC13H,  KQTYPE,  TAB, 

*  VAR,  DER,  NEQ,  RC18,  IC16,  I EULER,  RC18,  IC19,  RC20B, 

*  RC21 ,  IC21 ,  V4 ,  RC23,  NL,  NPTPLY,  WTIME,  IWIND 
GO  TO  999 

4.  READ  NEW  INPUT  DATA  FROM  INPUT  STREAM  FOR  RESTART. 

400  READ  (5,399)  AVAR, INDEX, I TYPE ,RR, II ,AA , RROLD , HOLD ,AAOLD 
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399  FORMAT (AS ,4I4,2(F8.0,I8,A8)) 

CALL  SEARCH(AVAR, INDEX, NCOM, ITEM) 
IF  (NCOM.LE.O)  GO  TO  490 

IF  (NCOM.GT. 24)  GO  TO  999 

IF  (ITYPE.GT.3)  GO  TO  490 

GO  TO  (  1 ,  2,  3.  4,  5,  6,  7, 

*  13,  14,  15,  16,  17,  18,  19, 

C  COMMON  /CONTRL/ 

1  IF  (ITEM.GT. 1)  GO  TO  401 

IF  (ITYPE.ME. 1)  GO  TO  490 

HOLD  =  TIME 

TIME  =  RR 
GO  TO  492 

401  IF  (ITEM.GT. 52)  GO  TO  490 
IF  (ITYPE.NE.2)  GO  TO  490 
I OLD  =  IC1 (ITEM-1) 

IC1 (ITEM-1)  =  II 
GO  TO  494 

C  COMMON  /CNTSRF/ 

2  IF  (ITEM.GT. 1888)  GO  TO  490 
IF  (ITYPE.NE. 1)  GO  TO  490 
HOLD  =  RC2 (ITEM) 

RC2 (ITEM)  =  RR 
GO  TO  492 

C  COMMON  /VPOSTN/ 

3  IF  (ITEM.GT. 18084)  GO  TO  403 
IF  (I TYPE  HE. 1)  GO  TO  490 
ROLD  -  RC3 ( ITEM) 

RC3 (ITEM)  =  RR 
GO  TO  492 

403  IF  (ITEM.GT. 18096)  GO  TO  490 
IF  (ITYPE.NE.2)  GO  TO  490 

I OLD  =  IC3 (ITEM- 18084) 

IC3( ITEM- 18084)  =  II 
GO  TO  494 

C  COMMON  /SGMNTS/ 

4  IF  (ITEM.GT. 900  )  GO  TO  404 

IF  (ITYPE.NE. 1)  GO  TO  490 

ROLD  =  RC4 (ITEM) 

RC4 ( ITEM)  =  RR 
GO  TO  492 

404  IF  (ITEM.GT. 930  )  GO  TO  490 
IF  (ITYPE.NE.2)  GO  TO  490 
IOLD  =  NSYM( ITEM-900) 
NSYM(ITEM-900)  =  II 

GO  TO  494 

C  COMMON  /CMATRX/ 

5  IF  (ITEM.GT. 1776)  GO  TO  490 
IF  (ITYPE.NE. 1)  GO  TO  490 
ROLD  =  RC5AQTEM) 
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8,  9,  10,  11.  12,  RSTART 

20,  21,  22,  23,  24)  ,  NCOM  RSTART 

RSTART 

RSTART 

RSTART 

RSTART 

RSTART 

RSTART 
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RSTART 
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RSTART 
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RC5A( ITEM)  =  HR 
GO  TO  492 
COMMON  /ABDATA/ 

6  IF  (ITEM. GT. 881  )  GO  TO  406 
IF  (ITYPE.NE. 1)  GO  TO  490 
ROLD  =  RC6A(ITEM) 

RC6A(ITEM)  =  RR 

GO  TO  492 

406  IF  ( ITEM. GT. 887  )  GO  TO  490 
IF  (ITYPE.NE. 2)  GO  TO  490 
I OLD  =  IFULL( ITEM-88 I) 

IFULL( ITEM-881)  =  II 
GO  TO  494 

COMMON  /TITLES/  NOTE:  NO  PROVISION  FOR  CGS  OR  JS. 

7  IF  ( ITEM. GT. 348  )  GO  TO  490 

IF  (ITYPE.NE. 3)  GO  TO  490 

AOLD  =  RC7A(ITEM) 

RC7A( ITEM)  =  AA 
GO  TO  496 
COMMON  /CNSNTS/ 

8  IF  (ITEM.GT. 35  )  GO  TO  490 

IF  (ITEM.GT. 31  )  GO  TO  408 

IF  (ITEM.LE.28  )  GO  TO  408 
IF  ' ITYPE.NE. 3)  GO  TO  490 

AOLD  *  RC8 (ITEM) 

RC8 (ITEM)  =  AA 
GO  TO  496 

408  IF  (ITYPE.NE. 1)  GO  TO  490 
ROLD  =  RC8 (ITEM) 

RC8 (ITEM)  =  RR 
rr  TO  492 
COMMON  /DESCRP/ 

9  IF  (ITEM.GT. 2460)  GO  TO  409 
IF  (ITYPE.NE. 1)  GO  TO  490 
ROLD  =  RC9UTEM) 

RC9 ( ITEM)  *  RR 
GO  TO  492 

409  IF  (ITEM.GT. 2610)  GO  TO  490 
IF  (ITYPE.NE. 2)  GO  TO  490 
I OLD  =  IC9( ITEM-2460) 

ICO (ITEM-2460)  =  II 
GO  TO  494 
COMMON  /JBARTZ/ 

10  IF  (ITEM.GT. 1614)  GO  TO  490 
IF  (ITYPE.NE. 2)  GO  TO  490 
I OLD  =  IC 10 (ITEM) 

ICIO(ITEM)  =  II 

GO  TO  494 
COMMON  /FORCES/ 

11  IF  (ITEM.GT. 1240)  GO  TO  411 
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GO  TO  490 
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SLIP 

RSTART 

RSTART 

RSTART 

RSTART 

SLIP 
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SLIP 

SLIPRT 

RSTART 

RSTART 
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RSTART 

RSTART 

RSTART 

RSTART 

RSTART 

NCFORC 


IF  (ITYPE.NE. 1)  GO  TO 

490 

RSTART 

ROLD  =  RC 1 1 ( ITEM) 

RSTART 

RC1 1 (ITEM)  =  RR 

RSTART 

GO  TO  492 

RSTART 

411 

IF  ( ITEM. GT. 1249)  GO  TO 

490 

NCFORC 

IF  (ITYPE.NE. 2)  GO  TO 

490 

RSTART 

IOLD  =  IC11 (ITEM- 1240) 

NCFORC 

IC11( ITEM- 1240)  =  II 

NCFORC 

GO  TO  494 

RSTART 

COMMON  /INTEST/ 

RSTART 

12 

IF  ( ITEM. GT. 720  )  GO  TO 

412 

RSTART 

IF  (ITYPE.NE. 1)  GO  TO 

490 

RSTART 

ROLD  =  RC 12 (ITEM) 

RSTART 

RC12 (ITEM)  =  RR 

RSTART 

GO  TO  492 

RSTART 

412 

IF  ( ITEM. GT. 840  )  GO  TO 

512 

RSTART 

IF  (ITYPE.NE. 3)  GO  TO 

490 

RSTART 

AOLD  =  SEGT( ITEM-720) 

RSTART 

SEGT( ITEM-720)  =  AA 

RSTART 

GO  TO  496 

RSTART 

512 

IF  ( ITEM. GT. 960  )  GO  TO 

490 

RSTART 

IF  (ITYPE.NE. 3)  GO  TO 

490 

RSTART 

AOLD  =  REGT (ITEM-840) 

RSTART 

REGT( ITEM-840)  =  AA 

RSTART 

GO  TO  496 

RSTART 

COMMON  /CSTRNT/ 

RSTART 

13 

IF  (ITEM.GT. 1212)  GO  TO 

413 

RSTART 

IF  (ITYPE.NE. 1)  GO  TO 

490 

RSTART 

ROLD  =  RC13A(ITEM) 

RSTART 

RC13A(ITEM)  =  RR 

RSTART 

GO  TO  492 

RSTART 

413 

IF  (ITEM.GT. 1248)  GO  TO 

490 

RSTART 

IF  (ITYPE.NE. 2)  GO  TO 

490 

RSTART 

IOLD  =  IC13 (ITEM-1212) 

RSTART 

IC13(ITEM-1212)  =  II 

RSTART 

GO  TO  494 

RSTART 

COMMON  /TABLES/ 

RSTART 

14 

IF  (ITEM.GT. 1304  )  GO  TO  414 

BOTLER2 

IF  (ITYPE.NE. 2)  GO  TO 

490 

RSTART 

IOLD  =  I C 1 4 ( ITEM) 

RSTART 

IC14 (ITEM)  =  II 

RSTART 

GO  TO  494 

RSTART 

414 

IF  (ITEM.GT. 5804)  GO  TO 

490 

MI  SC 

IF  (ITYPE.NE. 1)  GO  TO 

490 

RSTART 

ROLD  =  TAB (ITEM- 1304) 

BUTLER2 

TAB (ITEM- 1304)  =  RR 

BUTLER2 

GO  TO  492 

RSTART 

COMMON  /COMAIN/ 

RSTART 

15 

IF  (ITEM.GT. 485  )  GO  TO 

415 

RSTART 

IF  (ITYPE.NE. 1)  GO  TO 

490 

RSTART 
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ROLD  =  RC 15 (ITEM)  RSTART 

RC15(ITEM)  =  RR  RSTART 

GO  TO  492  RSTART 

415  IF  (ITEM. GT. 491  )  GO  TO  490  RSTART 

IF  (ITYPE.NE. 2)  GO  TO  490  RSTART 

IOLD  =  IC 15 (ITEM-485)  RSTART 

IC15 (ITEM-485)  =  II  RSTART 

GO  TO  494  RSTART 

COMMON  /CD I NT  /  RSTART 

16  IF  ( ITEM. GT. 5541)  GO  TO  416  RSTART 

IF  (ITYPE.NE. 1)  GO  TO  490  RSTART 

ROLD  =  RC 16 (ITEM)  RSTART 

RC 16 (ITEM)  =  RR  RSTART 

GO  TO  492  RSTART 

416  IF  (ITEM. GT. 5544)  GO  TO  490  RSTART 

IF  (ITYPE.ME. 2)  GO  TO  490  RSTART 

IOLD  =  IC16 (ITEM-5541)  RSTART 

IC16 (ITEM-5541)  =  II  RSTART 

GO  TO  494  RSTART 

COMMON  /DAMPER/  RSTART 

17  IF  ( ITEM. GT. 220  )  GO  TO  417  RSTART 

IF  (ITYPE.NE. 1)  GO  TO  490  RSTART 

ROLD  =  RC17 ( ITEM)  RSTART 

RC 17 (ITEM)  =  RR  RSTART 

GO  TO  492  RSTART 

417  IF  ( ITEM. GT. 260  )  GO  TO  490  RSTART 

IF  (ITYPE.NE. 2)  GO  TO  490  RSTART 

IOLD  =  IC17UTEM-220)  RSTART 

IC17 (ITEM-220)  =  II  RSTART 

GO  TO  494  RSTART 

COMMON  /CEULER/  RSTART 

18  IF  (ITEM.GT.30  )  GO  TO  418  RSTART 

IF  (ITYPE.NE. 2)  GO  TO  490  RSTART 

I OLD  -  I EULER (ITEM)  RSTART 

I EULER (ITEM)  =  II  RSTART 

GO  TO  494  RSTART 

418  IF  (ITEM. GT. 1350)  GO  TO  490  JDRIFT 

IF  (ITYPE.NE. 1)  GO  TO  490  RSTART 

ROLD  =  RC 18 (ITEM-30)  RSTART 

RC 18 (ITEM-30)  =  RR  RSTART 

GO  TO  492  RSTART 

COMMON  /TEMPVI/  RSTART 

19  IF  (ITEM. GT. 10  )  GO  TO  419  RSTART 

IF  (ITYPE.NE. 1)  GO  TO  490  RSTART 

ROLD  =  RC 19 (ITEM)  RSTART 

RC 19 (ITEM)  =  RR  RSTART 

GO  TO  492  RSTART 

419  IF  (ITEM. GT. 190  )  GO  TO  490  RSTART 

IF  (ITYPE.NE. 2)  GO  TO  490  RSTART 

IOLD  =  IC 19 (ITEM- 10)  RSTART 
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IC 19 (ITEM- 10)  =  II 
GO  TO  494 
COMMON/CYDATA/ 

20  IF  (ITEM. GT. 115  )  GO  TO  490 
IF  (ITYPE.NE. 1)  GO  TO  490 
HOLD  =  RC20A(ITEM) 
RC20A(ITEM)  =  RR 

GO  TO  492 
COMMON  /RSAVE/ 

21  IF  (ITEM. GT. 450  )  GO  TO  421 

IF  (ITYPE.NE. 1  )  GO  TO  490 

ROLD  =  RC21 (ITEM) 

RC21 (ITEM)  =  RR 
GO  TO  492 

421  IF  ( ITEM. GT. 970  )  GO  TO  490 

IF  (ITYPE.NE. 2  )  GO  TO  490 

IOLD  =  IC21 (ITEM-450) 

IC21 (ITEM-450)  =  II 
GO  TO  494 
COMMON  /FLXBLE/ 

22  IF  (ITEM. GT. 624  )  GO  TO  422 

IF  (ITYPE.NE. 1  )  GO  TO  490 

ROLD  =  RC22 ( ITEM) 

K022 ( ITEM)  =  RR 
GO  TO  492 

422  IF  ( ITEM. GT. 648  )  GO  TO  490 

IF  (ITYPE.NE. 2  )  GO  TO  490 

IOLD  =  IC22 (ITEM-624) 

IC22 ( ITEM-624)  =  II 
GO  TO  494 
COMMON  /HRNESS/ 

23  IF  (ITEM. GT. 1922)  GO  TO  423 
IF  (ITYPE.NE. 1)  GO  TO  490 
ROLD  =  RC23 ( ITEM) 

RC23 ( ITEM)  =  RR 


m 


424  IF  ( ITEM. GT. 1301)  GO  TO  490 
IF  (ITYPE.NE. 2)  GO  TO  490 
IOLD  =  IC24 ( ITEM- 150) 
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GO  TO  492 

RSTART 

423 

IF  ( ITEM. GT. 2687)  GO  TO 

490 

RSTART 

IF  (ITYPE.NE. 2)  GO  TO 

490 

RSTART 

IOLD  =  IC23 ( ITEM- 1922) 

RSTART 

IC23 (ITEM-1922)  =  II 

RSTART 

GO  TO  494 

RSTART 
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COMMON  /WINDFR/ 

RSTART 

24 

IF  (ITEM.GT. 150  )  GO  TO 

424 

WINDOP 
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IF  (ITYPE.NE. 1)  GO  TO 

490 

RSTART 

to-*-  * 

ROLD  =  RC24 ( ITEM) 

RSTART 
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RSTART 
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WINDOP 
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IC24 (ITEM- 150) =  II 
GO  TO  494 
C 

C  ERROR  MESSAGE  -  TERMINATE  PROGRAM. 

C 

490  WRITE  (6,491)  AVAR , INDEX, NCOM, ITEM, ITYPE ,RB. II ,AA 

491  FORMAT ( ’ 0  SUBROUTINE  RSTART  INPUT  ERROR’// 

»  ’  AVAR=  ’  ,A8  ,  ’  INDEX2  ’  ,316 ,  *  NC0M=\I6,’  ITEM* ’,16. 

*  ’  ITYPE= ’ , 16 , ’  RR= ’ , G 1 5 . 8  ,  ’  11= ’ . 18 , '  AA=  ’ ,A8// 

*  ’  PROGRAM  IS  BEING  TERMINATED.’) 

STOP  2 

C 

C  PRINT  MESSAGE  FOR  REAL  VARIABLES. 

C 

492  WRITE  (6,493)  AVAR, INDEX, COMMON (NCOM) .ROLD.RR 

493  FORMAT (’O’ ,A6,’ (’ ,14,’ ,’ ,14,’ ,14,')  OF  COMMON/ ’ ,A6 ,’/’ , 

»  ’  HAS  BEEN  CHANGED  FROM  ’.G15.8,’  TO  \G15.8) 

IF  (RROLD.EQ.O.O)  GO  TO  400 

IF  (DABS (RROLD-ROLD) .LE. 0.0000 l*RROLD)  GO  TO  400 
WRITE  (6,383)  RROLD 

383  FORMAT ( ’  INPUT  VALUE  FOR  RROLD  WAS  ’.G15.8//) 

GO  TO  490 

PRINT  MESSAGE  FOR  INTEGER  VARIABLES. 

C 

494  WRITE  (6,495)  AVAR, INDEX, COMMON( NCOM) , I OLD , II 

495  FORMAT (’O’ ,A6, ’ (’ ,14,’ ,’ ,14,’ ,’ ,14,’)  OF  COMMON/ ’ ,A6 ,’/’ , 

*  ’  HAS  BEEN  CHANGED  FROM  ’,  18,’  TO  18) 

IF  (IIOLD.EQ.O)  GO  TO  400 

IF  (IOLD.EQ.  HOLD)  GO  TO  400 
WRITE  (6,385)  HOLD 

385  FORMAT  ( ’  INPUT  VALUE  FOR  HOLD  WAS  ’,18//) 

GO  TO  490 
C 

C  PRINT  MESSAGE  FOR  ALPHANUMERIC  VARIABLES. 

C 

496  WRITE  (6,497)  AVAR, INDEX, COMMON (NCOM) ,AOLD,AA 

497  FORMAT (’O’ ,A6,’ (’ ,14,’ ,’ ,14,’ ,’,I4,’)  OF  COMMON/ ’ ,A6 ,’/’ , 

«  ’  HAS  BEEN  CHANGED  FROM  ’,  A8,’  TO  ’,  A8) 

IF  (AAOLD.EQ. BLANK)  GO  TO  400 
AA0LD4  =  AAOLD 

A0LD4  =  AOLD 

IF  ( A0LD4 . EQ . AA0LD4 )  GO  TO  400 
WRITE  (6,387)  AAOLD 

387  FORMAT (’  INPUT  VALUE  FOR  AAOLD  WAS  ’ ,A8//) 

GO  TO  490 

999  CALL  ELTIME (2 , 25) 

RETURN 

END 
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SUBROUTINE  SEARCH (AVAR, INDEX, NCOM, ITEM)  SEARCH 

REV  IV  07/24/86SLIP 

CALLED  BY  SUBROUTINE  RSTART  TO  COMPUTE  NCOM  &  ITEM  FROM  AVAR  &  SEARCH 
INDEX.  RETURNS  NC0M=0  FOR  ERROR  AND  NC0M=50  FOR  BLANK.  SEARCH 

SEARCH 

IMPLICIT  REAL*8 (A-H.O-Z)  SEARCH 
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EQUIVALENCE  (C3  (1),BVAR(  22))  ,  (NC3  (l).NDIM(l,  22))  PAGE 
EQUIVALENCE  (C4  (1),BVAR(  32))  ,  (NC4  (1),NDIM(1,  32))  PAGE 
EQUIVALENCE  (C5  (1),BVAR(  41))  ,  (NC5  (1),NDIM(1,  41))  PAGE 
EQUIVALENCE  (C6  (1),BVAR(  50))  ,  (NC6  (l).NDIM(l,  50))  SLIP 
EQUIVALENCE  (C7  (1),BVAR(  80))  ,  (NC7  (1),NDIM(1,  80))  SLIP 
EQUIVALENCE  (C8  (1),BVAR(  91))  ,  (NC8  (l).NDIM(l,  91))  SLIP 
EQUIVALENCE  (C9  (1) ,BVAR(101) )  ,  (NC9  (1) ,NDIM(1 , 101) )  SLIP 
EQUIVALENCE  (CIO ( 1)  ,BVAR( 1 16) )  ,  (NC10 ( 1) ,NDIM(  1 , 1 16) )  SLIP 
EQUIVALENCE  (Cll(l) ,BVAR(127))  ,  (NCI  1 ( 1 ) ,NDIM(  1 , 127) )  SLIP 
EQUIVALENCE  (Cl 2 ( 1 ) , BVAR( 137) )  ,  (NC12 ( 1 ) ,NDIM( 1 , 137) )  SLIP 
EQUIVALENCE  (C13 ( 1 ) , BVAR (141))  ,  (NC13 ( 1 ) ,NDIM( 1 , 141 ) )  SLIP 
EQUIVALENCE  (C 1 4 ( 1 ) ,BVAR( 157) )  ,  (NC14 ( 1) ,NDIM( 1 , 157) )  SLIP 
EQUIVALENCE  (C15  ( 1)  . BVAR ( 164) )  .  (NC15(1) ,NDIM(1 , 164) )  SLIP 
EQUIVALENCE  (C 16 ( 1 ) , BVAR( 177) )  ,  (NC16( 1) ,NDIM( 1 , 177) )  SLIP 
EQUIVALENCE  (C17 ( 1 ) ,BVAR (192))  ,  (NC17(1) ,NDIM(1 , 192) )  SLIP 
EQUIVALENCE  (C18 ( 1 ) , BVAR( 197) )  ,  (NC18 ( 1 ) ,NDIM( 1 , 197) )  SLIP 


3 


1 


ooo  ooo  ooo  ooo 


EQUIVALENCE  (C19 ( 1 ) ,BVAR(204) ) 

,  ( NC 19(1) 

, NDIMC 1 , 204) ) 

SLIP 

EQUIVALENCE  (C20(l) 

BVARC209) ) 

.  (NC20  ( 1) 

,  NDIM( 1 , 209) ) 

SLIP 

EQUIVALENCE  (C21 ( 1) ,BVAR(232) ) 

,  (NC21(1) 

,NDIM( 1,232)) 

SLIP 

EQUIVALENCE  (C22(l) ,BVAR(240) ) 

.  ( NC  22(1) 

, NDIMC 1 , 240) ) 

SLIP 

EQUIVALENCE  (C23 ( 1) tBVAR(244) ) 

,  (NC23  ( 1 ) 

.NDIMC 1 , 244) ) 

SLIP 

EQUIVALENCE  (C24(l) 

,BVAR(256) ) 

,  (NC24 ( 1) 

.NDIMC1 ,256) ) 

SLIP 

SEARCH 

DATA  NVAR/264/  ,  KOM/24/  .  BLANK/8H 

/ 

SLIP 

DATA  KOUNT/ 1,10, 22, 32, 4 1,50 ,80 

,91,101,116 

,127,137,141,157, 

SLIP 

164 , 177 ,192,197, 204 , 209 , 232 , 

240,244,256 

,265/ 

SLIP 

SEARCH 

COMMON/CONTRL/ 

SEARCH 

SEARCH 

DATA  Cl  /  8HTIME 

, 8HNSEG 

, 8HNJNT 

.8HNPL 

,  8HNBLT 

t 

SEARCH 

8HNBAG 

, 8HNVEH 

, 8HNGRND 

,  8  HNS 

,  8HNQ 

t 

SEARCH 

8HNSD 

, 8HNFLX 

, 8HNNRNSS 

.8HNWINDF 

, 8HNJNTF 

9 

SEARCH 

8HNPRT 

, 8HNPG 

/ 

PAGE 

DATA  NCI  /  0,0,0 

.  0,0,0 

.  0,0,0 

.  0,0,0 

,  0,0.0 

9 

SEARCH 

0,0.0 

.  0.0,0 

,  0,0,0 

,  0,0.0 

,  0,0,0 

9 

SEARCH 

0,0,0 

.  0,0,0 

,  0,0,0 

,  0,0,0 

,  0,0,0 

9 

SEARCH 

36,0,0 

.  0.0,0 

/ 

PAGE 

SEARCH 

COMMON/CNTSRF/ 

SEARCH 

SEARCH 

DATA  C2  /  8HPL 

.8HHELT 

.8HTPTS 

,8HBD 

/ 

SEARCH 

DATA  NC2  /  24,30,0 

.  20,8,0 

.  6,8,0 

o 

o 

c* 

/ 

EDGE 

SEARCH 

COMMON /VPOSTN/ 

SEARCH 

SEARCH 

DATA  C3  /  8HZPLT 

, 8HSPLT 

,0HAXV 

, 8HVATAB 

,8HVT0 

• 

SEARCH 

8HVDT 

, 8HTIMEV 

, 8H0MEGV 

, 8HNVTAB 

,  8HINDXV 

/ 

SEARCH 

DATA  NC3  /  3,0,0 

.  3.0,0 

,  3,6,0 

,  6,501,6 

,  6,0,0 

• 

VEHICL 

6,0,0 

,  6,0,0 

.  6,0,0 

,  6,0,0 

,  6,0,0 

/ 

SEARCH 

SEARCH 

COMMON/SGMNTS/ 

SEARCH 

SEARCH 

DATA  C4  /  8HD 

.8HWMEG 

, 8HWMEGD 

,  8HU1 

,8HU2 

f 

SEARCH 

8HSEGLP 

, 8HSEGLV 

, 8HSEGLA 

, 8HNSYM 

/ 

SEARCH 

DATA  NC4  /  3,3,30 

,  3,30,0 

,  3 , 30 , 0 

,  3 , 30 , 0 

,  3,30,0 

f 

SEARCH 

3,30,0 

,  3,30,0 

,  3,30,0 

,  30,0,0 

/ 

SEARCH 

SEARCH 

COMMON/CMATRX/ 

SEARCH 

SEARCH 

DATA  C5  /  8HV1 

,  8HV2 

,8HV3 

, 8HB12 

, 8HA22 

• 

SEARCH 

SHF 

,  8HTQ 

,  8HWJ 

,  8HA1 1 

/ 

SLIP 

DATA  NC5  /  3,30,0 

,  3,30,0 

.  3,12,0 

,  3,3,00 

,  3,3,60 

f 

SEARCH 

3,30,0 

,  3,30,0 

.  30,0,0 

,  3,3,60 

/ 

SLIP 

6  COMMON/ABDATA/ 


SEARCH 

SEARCH 

SEARCH 


357 


o  o  a 


DATA 

C6  /  8HZDEP 

.  8HDBR 

, 8HDPVCTR 

,  8HDEPL0Y 

,  8HAB 

» 

SEARCH 

ft 

8HB 

,  8HZR 

. SHBFB 

, 8HDRR 

, 8HVBAGG 

« 

SEARCH 

* 

8HVSCS 

, 8HSPRK 

,  8HCK 

,  8HCMASS 

,  8HCYMIN 

t 

SEARCH 

« 

8HCYM0UT 

, 8HBAGPV 

,  8HPD 

, 8HVBAG 

, 8HV0LBP 

i 

SEARCH 

* 

8HPCYV 

, 8HPCYMIN 

,  8HPVBAG 

.8HTV1 

,8HTV2 

* 

SEARCH 

« 

8HSWITCH 

, 8HPYM0DT 

,  8HSCALE 

, 8HPREVT 

, 8HIF0LL 

/ 

SEARCH 

DATA 

NC6  /  3,5,0 

,  3,3,5 

.  3,5,0 

,  3,5,0 

,  3,5,0 

f 

SEARCH 

ft 

9.4,5 

.  3,4.5 

,  3.4.5 

.  9.4,5 

,  5,0.0 

• 

SEARCH 

ft 

5,0,0 

.  5,0.0 

,  5.0,0 

,  5,0,0 

,  5,0,0 

« 

SEARCH 

ft 

5,0,0 

,  5.0,0 

,  5,0,0 

,  5,0,0 

,  5,0,0 

9 

SEARCH 

ft 

5.0.0 

.  5,0,0 

,  5,0,0 

,  3,4,5 

,  3,10,5 

9 

SEARCH 

ft 

5,0,0 

.  5,0.0 

,  5,0,0 

.  0,0.0 

.  6,0.0 

/ 

SEARCH 

c 

SEARCH 

c 

7 

COMMON/TITLES/ 

SEARCH 

c 

SEARCH 

DATA 

C7  /  8HDATE 

.8HC0MENT 

.8HVPSTTL 

,  8HBDYTTL 

, 8HBLTTTL 

9 

SEARCH 

ft 

8HPLTTL 

, 8HBAGTTL 

,  8HSEG 

, 8HJ0INT 

,  8HCGS 

9 

SEARCH 

ft 

8HJS 

/ 

SEARCH 

DATA 

NC7  /  3,0,0 

,  40,0.0 

,  20,0,0 

,  5,0,0 

,  5,8,0 

9 

SEARCH 

ft 

5,30,0 

,  5,6,0 

.  30,0,0 

.  30,0,0 

,  30,0,0 

9 

SEARCH 

ft 

30,0,0 

/ 

SEARCH 

c 

SEARCH 

c 

8 

COMMON/CNSNTS/ 

SEARCH 

c 

SEARCH 

DATA 

C8  /  8HPI 

.8HRADIAN 

,8HG 

.8HTHIRD 

, 6HEPS 

9 

SEARCH 

ft 

8HUNITL 

, 8HUNITM 

.8HUNITT 

, 8HGRAVTY 

,  8HTW0PI 

/ 

TWOPI 

DATA 

NC8  /  0,0,0 

,  0,0,0 

,  0,0,0 

,  o.o.o 

,  24,0,0 

» 

SEARCH 

ft 

0,0,0 

.  0,0,0 

,  0,0,0 

i  3,0,0 

,  0,0,0 

/ 

TWOPI 

c 

SEARCH 

c 

9 

COMMON/ DESCRP/ 

SEARCH 

c 

SEARCH 

DATA 

C9  /  8HPHI 

,  8HW 

,8HRW 

,8HSR 

,8HHA 

» 

SEARCH 

ft 

8HHB 

.8HRPHI 

,8HHT 

,  8HSPRING 

, 8HVISC 

» 

SEARCH 

ft 

8HJNT 

, 8HJPIN 

,  8HJSING 

,  8HJGL0B 

, 8HJ0INTF 

/ 

SEARCH 

DATA 

NC9  /  3,30,0 

.  30,0,0 

,  30,0,0 

,  4,60,0 

,  3 , 60 , 0 

f 

SLIP 

ft 

3,60,0 

,  3,30,0 

,  3,3,60 

,  5,90,0 

,  7,90,0 

1 

SEARCH 

ft 

30,0,0 

,  30,0,0 

,  30,0,0 

,  30,0,0 

,  30,0,0 

/ 

SEARCH 

c 

SEARCH 

c 

10 

COMMON/ JBARTZ/ 

SEARCH 

c 

SEARCH 

DATA 

CIO/  8HMNPL 

, 8HMNBLT 

.8HMNSEG 

.8HMNBAG 

.8HMPL 

f 

SEARCH 

ft 

8HMBLT 

, 8HMSEG 

, 8HMBAG 

.8HNTPL 

, 8HNTBLT 

9 

SEARCH 

ft 

8HNTSEG 

/ 

SEARCH 

DATA 

NC10/  30,0,0 

,  8,0,0 

,  30,0,0 

,  6,0,0 

,  3,5, 30 

9 

SEARCH 

ft 

3,5,8 

,  3,5,30 

,  3,10,6 

,  5,30,0 

,  5,8,0 

9 

SEARCH 

ft 

5,30,0 

/ 

SEARCH 

c 

SEARCH 

c 

1 1 

COMMON/FORCES/ 

SEARCH 

c 

SEARCH 

DATA 

C 1 1 /  8HPSF 

.8HBSF 

, 8HSSF 

.8HBAGSF 

, 8HPBJNT 

9 

SEARCH 

«  8HNPANEL 

.8HNPSF 

.8HNBSF 

.8HNSSF 

.8HNBGSF 

/ 

SEARCH 

DATA  NCI  1/  7,70,0 

4,20,0  , 

10.40,0  , 

3,20,0 

7,30,0 

NCFORC 

»  5,0.0 

.  0,0,0 

.  0,0.0 

,  0,0,0 

.  0,0,0 

/ 

SEARCH 

c 

SEARCH 

c 

12 

COMMON/ INTEST/ 

SEARCH 

c 

SEARCH 

DATA  C12/  8HSGTEST 

.8HXTEST 

.8HSEGT 

, 8HREGT 

/ 

SEARCH 

DATA  NC12/  3,4,30 

,  3,120,0 

,  120,0,0 

,  120,0,0 

/ 

SEARCH 

c 

SEARCH 

c 

13 

COMMON/CSTHNT/ 

SEARCH 

c 

SEARCH 

DATA  C13/  8HA13 

, 8HA23 

.8HB31 

,8HB32 

.8HHHT 

t 

SEARCH 

*  8HRK1 

, 8HRK2 

,8HQQ 

, 8HTQQ 

, 8HRQQ 

t 

SEARCH 

«  8HHQQ 

. 8HSQQ 

, 8HCFQQ 

, 8HKQ1 

, 8HKQ2 

t 

SEARCH 

»  8HKQTYPE 

/ 

SEARCH 

DATA  NC13/  3,3,24 

.  3,3,24 

.  3,3.24 

,  3,3,24 

.  3,3,12 

l 

SEARCH 

«  3,12,0 

.  3.12.0 

.  3,12,0 

,  3,12,0 

,  3.12,0 

f 

SEARCH 

*  3,12,0 

,  12,0,0 

,  12,0.0 

,  12,0.0 

,  12,0,0 

• 

SEARCH 

*  12,0,0 

/ 

SEARCH 

c 

SEARCH 

c 

14 

COMMON/TABLES/ 

SEARCH 

c 

SEARCH 

DATA  C14/  8HMXNTI 

, 8HMXNTB 

.8HMXTB1 

.8HMXTB2 

.8HNTI 

• 

SEARCH 

*  8HNTAB 

, 8HTAB 

/ 

SEARCH 

DATA  NC14/  0,0,0 

i  0,0,0 

,  0,0,0 

,  0,0,0 

,  50,0,0 

• 

SEARCH 

*  1250,0,0 

,  4500,0.0/ 

BUTLER2 

c 

SEARCH 

c 

15 

COMMON/COMAIN/ 

SEARCH 

c 

SEARCH 

DATA  Cl 5/  8HVAR 

, 8HDER 

,8HDT 

,8HH0 

.8HHMAX 

f 

SEARCH 

*  8HHMIN 

, 8HRSTIME 

.8HISTEP 

, 8HNSTEPS 

, 8HNDINT 

l 

SEARCH 

*  8HNEQ 

,  9HIRSIN 

, 8HIRS0UT 

/ 

SEARCH 

DATA  NC15/  240,0,0 

,  240,0,0 

,  0,0,0 

,  0,0,0 

,  0,0,0 

« 

SEARCH 

*  0,0,0 

,  0,0,0 

,  0,0,0 

.  0,0,0 

,  0,0.0 

» 

SEARCH 

*  0,0,0 

,  0,0,0 

.  0,0,0 

/ 

SEARCH 

c 

SEARCH 

c 

16 

COMMON/CDINT  / 

SEARCH 

c 

SEARCH 

DATA  C16/  8HUU 

,8HGH 

,  8HE 

,8HFF 

,8HGG 

* 

SEARCH 

*  8HY 

,  8  HU 

,  8HH 

.8HHPRINT 

,  8HHS 

1 

SEARCH 

»  8HTPRINT 

, 8HTSTART 

, 8HICNT 

,  8HIDBL 

,  8HIFLAG 

/ 

SEARCH 

DATA  NC16/  4,0,0 

.  3,4,0 

,  3,240,0 

,  5,240,0 

,  5,240,0 

» 

SEARCH 

»  5,240,0 

,  5,240,0 

.  0,0,0 

,  0,0,0 

,  0,0,0 

• 

SEARCH 

»  0,0,0 

.  0,0,0 

.  0,0,0 

,  0,0,0 

,  0,0,0 

/ 

SEARCH 

c 

SEARCH 

c 

17 

COMMON/ DAMPER/ 

SEARCH 

c 

SEARCH 

DATA  C 17/  8HAPSDM 

.8HAPSDN 

.8HASD 

.8HMSDM 

.8HMSDN 

/ 

SEARCH 

DATA  NCI 7/  3,20,0 

,  3,20,0 

.  5,20,0 

,  20,0,0 

,  20,0,0 

/ 

SEARCH 

c 

SEARCH 

*  7,30,0  ,  6,0,0  ,  5,0,0  ,  30,30,0 

NCOM  =  50 

IF  (AVAR. EQ. BLANK)  60  TO  99 

SEARCH  FOR  VARIABLE  NO.  IV. 

NCOM  =  0 
DO  10  IV= I ,NVAR 
IF  (AVAR.EQ.BVAR(IV) )  GO  TO  12 
10  CONTINUE 
GO  TO  99 

SEARCH  FOR  COMMON  NO.  IC. 

12  DO  20  IC= 1 , KOM 

IF  (IV.GE.KOUNT(IC) . AND . IV.LT . KOUNT ( IC+ 1) )  GO  TO  22 
20  CONTINUE 
GO  TO  99 

COMPUTE  ITEM  NO.  FOR  VARIABLE  IV  IN  COMMON  IC. 

22  K1  =  KOUNT (IC) 

K2  =  IV-1 
ITEM  =  1 

IF  ( K 1 .EQ. IV)  GO  TO  25 
DO  24  K=K1 ,K2 
NI  =  1 
DO  23  1=1,3 

IF  (NDIM(I ,K) .NE.O)  NI=NI»NDIM(I ,K) 

23  CONTINUE 

24  ITEM  =  ITEM+NI 

25  DO  26  1=1,3 

IF  (INDEX(I) .EQ.O  .AND.  NDIM(I , IV) .ME. 0)  GO  TO  99 
IF  (NDIM(I.IV) .EQ.O  .AND.  I NDEX ( I ) . GT . 1 )  GO  TO  99 
NJ (I )  =  MAXO ( I NDEX ( I ) -1,0) 

NK(I)  =  MAXO (NDIM( I , IV) ,1) 

IF  (NJ(I) . GE.NK(I) )  GO  TO  99 

26  CONTINUE 

ITEM  =  ITEM+NJ ( l) +NJ (2) »NK ( 1) +NJ (3) *NK (2) «NK( 1) 

NCOM  =  IC 
99  RETURN 
END 


WINDOP 

SEARCH 

SEARCH 

SEARCH 

SEARCH 

SEARCH 

SEARCH 

SEARCH 

SEARCH 

SEARCH 

SEARCH 

SEARCH 

SEARCH 

SEARCH 

SEARCH 

SEARCH 

SEARCH 

SEARCH 

SEARCH 

SEARCH 

SEARCH 

SEARCH 

SEARCH 

SEARCH 

SEARCH 

SEARCH 

SEARCH 
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SEARCH 

SEARCH 

SEARCH 

SEARCH 

SEARCH 

SEARCH 

SEARCH 

SEARCH 

SEARCH 

SEARCH 

SEARCH 

SEARCH 

SEARCH 

SEARCH 
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SUBROUTINE  SEGSEG(M.MM,N,NS , NT)  SEGSEG 

C  REV  IV  02/07/87HYPER 

IMPLICIT  REAL*8 (A-H.O-Z)  SEGSEG 

COMMON/TABLES/MXNTI , MXNTB . MXTB 1 , MXTB2 , NTI ( 50) , NTAB (1250), TAB (4500) SEGSEG 
COMMON/CNTSRF/  PL(24 . 30) , BELT (20 , 8) ,TPTS (6 , 8) ,BD(24 , 40)  EDGE 

COMMON/ SGMNTS/  D(3,3.30) ,WMEG(3,30) , WMEGD(3,30) ,U1(3,30) ,U2(3,30) .SEGSEG 

*  SEGLP(3,30) ,SEGLV(3,30) ,SEGLA(3,30) ,NSYM(30)  SEGSEG 

COMMON/FORCES/PSF (7,70) ,BSF(4,20) ,SSF(10,40) ,BAGSF(3,20) ,  NCFORC 

*  PRJNT(7,30) ,NPANEL(5) ,NPSF,NBSF,NSSF,NBGSF  SEGSEG 

COMMON/CSTRNT/  A13(3,3,24) ,A23(3,3,24) ,B31 (3,3,24) ,B32(3,3,24) ,  SEGSEG 

»  HHT (3,3,12) , RK 1 ( 3 , 1 2 ) ,RK2(3.12) ,QQ(3,12) ,TQQ(3,12) .SEGSEG 

»  RQQ  (3 ,12) ,HQQ (3 ,12) ,  SQQ (12) ,CFQQ ( 12) ,  SEGSEG 

«  KQ 1(12) ,KQ2(12) ,KQTYPE(12)  SEGSEG 

COMMON/RSAVE/  XSG(3 , 20 , 3) .DPMI (3 , 3 , 30) ,LPMI (30) ,  TGM0D7 

*  NSG(9) ,MSG(20,9) , MCG , MCGIN ( 24 , 5 ) ,KREF(20,9)  TGM0D7 

COMMON/TEMPVS/DMNT (3 ,3)  . TEMPO, 3)  , B (3 , 3)  ,XMN(3)  ,RLN(3)  ,XMM(3)  ,  SEGSEG 

*  TM(3) ,R(3) ,RM(3) ,DMNWN(3) ,RLM(3) ,RN(3) , VMN(3) ,VR(3) ,  SEGSEG 

*  WNM(3) ,WCM(3) ,WCN(3) ,VREL(3) ,FFM(3) ,FR(3) ,TQM(3) .  SEGSEG 

*  TQN (3) ,TQNT (3) ,T(3) ,H(3) , T 1 ( 3 ) ,T2(3) , RMD (3) , RND (3) ,  SEGSEG 

*  TD(3) ,TT4(3,4) ,TT5(3,4) ,T3(3) ,T4(3) , P , AMR ,FM,CF ,  SEGSEG 

*  VRM , VRT , VRTS , VRTEST , TF , ELOSS . MCF , NCF , T5 ( 3 ) , T6 ( 3 )  TGM0D7 

CALL  ELTIME ( 1 , 23)  SEGSEG 

EDGE 

COMPUTATIONS  ARE  DONE  IN  M'S  REFERENCE  SYSTEM  EDGE 

NN  =  IABS(NS)  SEGSEG 

CALL  D0TT33 (D ( 1 , 1 ,M) ,D ( 1 , 1 ,N) , DMNT)  SEGSEG 

DO  10  I  =  1.3  SEGSEG 

10  XMN(I)  =  SEGLP ( I , M)  -  SEGLP(I.N)  SEGSEG 

CALL  MAT31 (D ( 1 , 1 ,M) .XMN.XMM)  SEGSEG 

J  =  3  HYPER 

IF (BD ( 1 ,NN) .LT.O.O) J  =  4  HYPER 

CALL  MAT31 (DMNT,BD(J+1 ,NN) , RLN)  HYPER 

J  =  3  HYPER 

IF(BD(1 , MM) .LT.O.O) J  =  4  HYPER 

DO  15  I  =  1,3  EDGE 

J  =  J  +  1  HYPER 

15  R ( I )  =  RLN ( I )  -  XMM(I)  -  BD ( J , MM)  HYPER 

LT  =  NTAB (NT)  SEGSEG 

TB  =  1.0  EDGE 

IF ( (BD ( 1 , MM) . GT . 0 . 0) . AND . (BD ( 1 , NN) .GT . 0 . 0) ) GO  TO  20  HYPER 

C  NEW  HYPERELLIPSOID  -  AT  LEAST  ONE  SURFACE  IS  A  HYPERELLIPSOID  HYPER 

IF  (BD ( 1 .MM) .LT.O.O. AND. BD(23, MM) .NE. 0.0)  STOP  23  HYPER 

IF  (BD ( 1 .NN) .LT.O.O. AND. BD(23,NN) .NE. 0.0)  STOP  23  HYPER 

C  A  HYPERELLIPSOID  MUST  HAVE  IDENTICAL  POWERS.  HYPER 

C  IF(NS.LT.O)  STOP  -  INTERIOR  INTERSECTION  NOT  OPERATIONAL  HYPER 

IF(NS.LT.O)  STOP  38  HYPER 

IF(TAB(LT+23) .LE. 1.0)  CALL  HYEST (BD ( 1 , MM) ,BD ( 1 , NN) .TAB (LT+22) )  HYPER 

IF(TAB(LT+23) .GT.1.0)  CALL  HYNTR(BD(1 ,MM)  ,BD(1 ,NN) , TAB (LT+22) )  HYPER 

BET  =  TAB (LT+23)  HYPER 

I F ( BET . GT . 1 . 0 ) TB  =  1.0/BET  HYPER 


O  O  O  O  O  O  O  O  d 


GO  TO  25 

C  OLD  ELLIPSOIDS 

20  IF (NS.LT.O.O)TB  =  -TB 

CALL  D0TT33(BD(7.NN) , DMNT, TEMP) 

CALL  MAT33 ( DMNT , TEMP , B ) 

CALL  INTERS (BD (7 ,MM) ,B,R,TB,RM,TAB(LT+22) ,TM) 

A  B  R  Z  C  AZ 

INTERS  SOLVES  (CA  +  B)Z  =  BR,  TB  =  SQRT(Z.AZ) 

25  MCF  =  NTAB (NT+ 1 ) 

NCF  =  -MCF 

IF (NCF .GT. 0) CFQQ (NCF)  =  -999. 

CHECK  FOR  INTERSECTION 

IF(TB.GE. 1 .0)GO  TO  75 

51  =  0.0 

52  =  0.0 
DO  30  I  =  1,3 
RI  =  R(I) 

IF(NS.LT.O)RI  =  RM(I)  ♦  TB»(RM(I)  -  R(D) 

SI  =  SI  ♦  RI»«2 
30  S2  =  S2  +  TM(I)»*2 
AMR  =  DSQRT(S2) 

P  =  (1.0/TB  -  1.0)«DSQRT(S11 
J  =  3 

JF(BD(1.MM) .LT.O.OJJ  =  4 
DO  35  I  =  1,3 
J  =  J  +  1 

I F ( ( BD ( 1 ,MM) .LT.O.O) .OR. (BD( 1 ,NN) . LT.O.O) )BM( I)  =  TB«RM(I) 
TM( I )  =  -TM( I ) /AMR 
T2 ( I )  =  RM( I )  -  R(I) 

RN ( I )  =  T2 (I)  +  RLN(I) 

35  RLM(I)  =  RM( I )  +  BD(J,MM) 

CALL  D0T3 1 ( DMNT . RN , RLN ) 

CALL  PLSEGF(M,N,NT) 

STORE  PRINT  DATA 

SSF(l.NSSF)  =  P 
DO  40  I  =  1,3 
SSF (1+4 ,NSSF)  =  RLM(I) 

40  SSF ( I +7 ,NSSF)  =  RLN ( I ) 

IF (LPMI (M) . NE . 0)  CALL  D0T31 (DPMI ( 1 , 1 ,M> .RLM.SSF (5 ,NSSF) ) 
IF(LPMI(N) .NE.O)  CALL  D0T31 (DPMI ( 1 , 1 ,N) , RLN, SSF(8 ,NSSF) ) 

IF (MCF . LT . 0) GO  TO  45 
SSF (2 ,NSSF)  =  FM 
TF2FM2  =  TF*»2  -  FM*»2 
IF (TF2FM2 . LT. 0 . 0) TF2FM2  =  0.0 
SSF (3 . NSSF)  =  DSQRT (TF2FM2) 
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HYPER 

HYPER 

HYPER 

EDGE 

EDGE 

SEGSEG 

EDGE 

EDGE 

EDGE 

HYPER 

SEGSEG 

SEGSEG 

EDGE 

EDGE 

EDGE 

HYPER 

SEGSEG 

SEGSEG 

HYPER 

SEGSEG 

SEGSEG 

SEGSEG 

HYPER 

SEGSEG 

SEGSEG 

HYPER 

HYPER 

HYPER 

HYPER 

HYPER 

SEGSEG 

SEGSEG 

SEGSEG 

HYPER 

SEGSEG 

SEGSEG 

EDGE 

EDGE 

EDGE 

SEGSEG 

HYPER 

EDGE 

HYPER 

EDGE 

EDGE 

HYPER 

SEGSEG 

SEGSEG 

SEGSEG 

SEGSEG 


SSF (4 ,NSSF)  =  TF  SEGSEG 

GO  TO  75  HYPEB 

EDGE 

ROLL-SLIDE  EDGE 

45  DO  50  I  =  1,3  HYPER 

50  SSF (1+ 1 ,NSSF)  =  T(I)  HYPER 

IF( (BD(1 ,MM) .LT.O.O) .OR. (BD(1 ,NN) . LT.O.O) )  STOP  29  HYPER 

ANR  =  XDY (TM.B.T2)  SEGSEG 

CALL  CROSS (TM.WNM.T2)  SEGSEG 

CALL  MAT31 (B.VR.Tl)  SEGSEG 

TB  =  TM( 1) *T1 ( 1)  +  TM(2) »T1 (2)  +  TM(3)«T1(3)  EDGE 

DO  60  I  =  1,3  HYPER 

DO  55  J  =  1.3  HYPER 

K  =  I  +  3* ( J+ 1 )  SEGSEG 

TT4 ( I , J)  =  BD (K , MM) /AMR  +  B(I,J)/ANR  SEGSEG 

55  TT5 (I , J)  =  TT4 ( I , J)  HYPER 

TT4 (1,4)  =  T2(I)  -  (Tl(I)  -  TB*TM(I) ) /ANR  EDGE 

60  TT5 (1,4)  =  TM(I)  HYPER 

CALL  DSMS0L(TT4 ,3,3)  SEGSEG 

CALL  DSMSOL (TT5 ,3,3)  SEGSEG 

51  =  TM( 1 ) »TT4 (1,4)  +  TM(2) «TT4 (2 ,4)  ♦  TIK3) »TT4 (3 ,4)  EDGE 

52  =  (TM( 1 ) *TT5 (1,4)  +  TM(2) #TT5 (2 ,4)  +  TM( a) *7T5 (3 ,4) ) /SI  EDGE 

DO  65  I  =  1,3  HYPER 

RMD(I)  =  TT4 (1,4)  -  S2«TT5(I,4)  EDGE 

65  RND(I)  =  RND(I)  +  VR ( I )  HYPER 

CALL  CROSS (DMNWN.RND.T1)  EDGE 

CALL  CROSS (WMEG(1 ,MM) .RMD.T2)  EDGE 

CALL  MAT31 (B.RND.T3)  EDGE 

CALL  CROSS (DMKWN.TM.T4)  EDGE 

SI  =  TM( 1) »T3 ( 1)  +  TM(2) »T3 (2)  ♦  TM(3)*T3(3)  EDGE 

SQQ(MCF)  =  0.0  SEGSEG 

DO  70  1  =  1.3  HYPER 

T 1 ( I )  =  Tl(I)  -  T2 ( I )  EDGE 

70  SQQ(NCF) =SQQ (NCF) +TM(I) *T1 (I ) -VB(I) » (T4 (I) + (T3 ( I) -S1«TM(I) ) /ANR)  HYPER 
CALL  DOT3 1(D(1,1,M) , T 1 , RQQ ( 1 , NCF ) )  EDGE 

75  CALL  ELTIME(2 ,23)  HYPER 

RETURN  SEGSEG 

END  SEGSEG 


SUBROUTINE  SETUP  1  SETUPI 

REV  IV  07/24/86SLIP 

FOR  KK-  1  (BEFORE  CONTACT  ROUTINE  IN  DAUX)  SETUP1 

SET  UP  INITIAL  VALUES  OF  A2  AND  B2  ARRAYS  FOR  THIS  TIME  POINT.  SETUPI 

SET  UP  INITIAL  VALUES  OF  ARRAYS  U1.U2  AND  VI.  SETUPI 

SETUPI 

IMPLICIT  REAL»8 (A-H.O-Z)  SETUPI 

COMMON /CONTRL/  T I ME , NSEG , NJNT , NPL , NBLT , NBAG , NVEH , NGRND ,  SETUPI 

*  NS , NQ , NSD , NFLX . NHRNSS , NWINDF , NJNTF , NPRT ( 36 ) , NPG  PAGE 

COMMON/SGMNTS/  D(3,3,30) ,WMEG(3,30) ,WMEGD(3,30) ,U1(3,30) ,U2(3,30) .SETUPI 

*  SEGLP(3,30) ,SEGLV(3,30) ,SEGLA(3,30) ,NSYM(30)  SETUPI 

COMMON/DESCRP/  PHI (3,30) ,W(30) ,RW(30) ,SR(4.60) ,HA(3,60) ,HB(3,60) .  SLIP 

*  RPHI (3,30) ,HT (3 ,3 , 60) , SPRING (5 , 90) , VISC (7 ,90) ,  SETUPI 

»  JNT(30) ,IPIN(30) ,ISING(30) ,IGL0B(30) ,J0INTF(30)  SETUPI 

COMMON/CMATRX/  VK3.30) ,V2(3,30) ,V3(3,12) ,B12(3,3,60) ,A22(3,3,60) .SETUPI 
»  F  (3 , 30)  ,TQ  (3 , 30)  ,  WJ  (30)  ,  A1 1  (3 , 3 , 30)  SLIP 

COMMON/CEULER/  IEULER(30) ,HIR(3 , 3 , 90) . ANG(3 ,30) , ANGD (3 , 30) ,  SLIP 

*  FE(3,30) ,TQE(3,30) ,C0NST(5,30)  SLIP 

COMMON/TEMPVS/T (3) ,S(3) ,T1 (3) ,T2(3) ,T3(3) ,T4(3) ,T5(3) ,T6(3) .  SETUPI 

*  T7(3) ,T8(3) ,T9(3) , T 1 0 (3) , T 1 1 ( 3 ) , T 1 2 (3) ,HH(3) ,  SETUPI 

*  TTH3.3)  ,TT2(3,3)  ,  SI ,  SQS1 ,  S2  ,S3 ,  S4  ,  V1T ,  SR2  SLIP 

DATA  IFIRST/1/  SLIP 

SETUPI 

CALL  ELTIME ( 1 , 10)  SETUPI 

IF  (IFIRST.EQ.O)  GO  TO  15  SLIP 

IF  (NJNT.EQ.O)  GO  TO  15  SLIP 

DO  10  I  *  1 , NJNT  SLIP 

DO  10  J  =  1,3  SLIP 

DO  8  K  =  1,3  SLIP 

8  All(J.K.I)  =  0.0  SLIP 

10  All (J , J , I )  =  1.0  SLIP 

IFIRST  =  0  SLIP 

15  DO  20  1=1, NGRND  SLIP 

SETUPI 

SET  EACH  U1N  =  0  SETUPI 

SETUPI 

Ul( 1,1)  =  0.0  SETUPI 

U 1 (2,1)  =  0.0  SETUPI 

UK3.I)  =  0.0  SETUPI 

SETUPI 

SET  EACH  U2N  =  WNX(PHIN*WN)  SETUPI 

SETUPI 

U2 (1,1)  =  WMEG(2 , I ) *WMEG(3 , I)  «  (PHI (2 , I) -PHI (3 , I ) )  SETUPI 

U2 (2 , I)  =  WMEG(1 ,I)*WMEG(3,I)  »  (PHI (3 , I) -PHI ( 1 , I) )  SETUPI 

20  U2 (3 , I )  =  WMEG( 1,1) »WMEG(2 , I )  «  (PHI (1 , I ) -PHI (2 , I) )  SETUPI 

IF  (NPRT (11) . NE . 0)  WRITE  (8,21)  ( (U2 ( I , J) ,1=1,3) , J=1 , NSEG)  SETUPI 

21  FORMAT ( ’  U2  ARRAY’ / ( IX , 1P9D14 . 4) )  SETUPI 

IF  (NJNT.LE.O)  GO  TO  9B  SETUPI 

DO  40  J  = 1 , NJNT  SETUPI 

DO  31  K* 1.3  ,  SETUPI 


4 


T1(K)  =  SR(K,2*J-1) 

T2(K)  =  SR(K , 2* J  ) 

IF  ( IABS (IPIN( J) ) .LT.5)  GO  TO  31 
IF  (IEULER(J) .EQ.-l)  GO  TO  31 
T1(K)  =  T1(K)  +  SR(4 , 2»J- 1) *HT (K , 3 , 2»J- I) 
31  V1(K,J)  =  0.0 
I  =  IABS ( JNT ( J) ) 

IF  (I.LE.O)  GO  TO  40 


FOR  EACH  JOINT  SET 

B12 (2J- 1 )  =  B12IJ.I  )  =  — D ( I ) ’  «  SR(2J-1)  X 
B 1 2 ( 2 J  )  =  B12(J, J+l)  =  D(J+1) '  »  SR(2J)  X 


B12 ( 1 , 
B12 (2 , 
B12 (3 , 
B12  ( 1  , 
B12 (2 , 
B12 (3 , 
B12 ( 1 , 
B12 (2 , 
B12 (3 , 


1 . 2* J- 1 ) 
1 . 2« J- 1 ) 
1 . 2* J- 1 ) 
2 ,  2*J- 1 ) 
2 ,  2*J- 1 ) 
2 ,  2*J- 1 ) 
3 . 2*J- 1) 
3 , 2*J- 1 ) 
3 . 2*J- 1 ) 


D  (3 , 1 , 1 ) 
D  (3 , 2 , 1 ) 
D (3 ,3 , 1) 
D(l.l.I) 
0  ( 1 , 2 , 1) 
D ( 1 , 3 , 1) 
D  (2 . 1 . 1) 
D  (2 , 2 , 1) 
D  (2 , 3 . 1) 


*T 1(2) 
»T1 (2) 
»T1 (2) 
*T1 (3) 
*T1 (3) 
*T1 (3) 
*T1(1) 
*T1 ( 1 ) 
*T1(1) 


«T1 (3) 
i  *T1 (3) 
i  *T1 (3) 
i  »T1 ( 1) 
i  *T1 (1) 
i«Tl(l) 
i  *T1 (2) 
>*T1(2) 
l  *T1 (2) 


B12 (1.1 ,2*J 
B12 (2 , 1 ,  2»J 
B12 (3 , 1 ,2»J 
B12 ( 1 ,2 , 2*J 
B 1 2 ( 2 , 2 , 2* J 
B12 (3 , 2 , 2#J 
B 1 2 ( 1 , 3 , 2* J 
B12  (2 ,3 ,2*J 
B12 (3 , 3 , 2*J 


D  (2 . 1 
D  (2 , 2 
D  (2 , 3 
D  (3 . 1 
D  (3 , 2 
D  (3 , 3 
D  ( 1 .  1 
D  ( 1 , 2 
D(  1 ,3 


,  J+ 1 ) *T2 (3) 
,  J+ 1 ) »T2 (3) 
,  J+ 1) *T2 (3) 
,J+1) *T2(1) 
,  J+ 1) *T2 (1) 
,  J+ 1) «T2 ( 1) 
,  J+l) »T2(2) 
,  J+ 1 ) *T2 (2) 
,  J+ 1 ) *T2 (2) 


D(3 , 1 
D(3 ,2 
D(3 ,3 
D  ( 1 , 1 
D(1 ,2 
D(1 ,3 
D(2 , 1 
D(2 ,2 
D(2 ,3 


,J+1) 
,  J+l) 
.J+l) 
,J+1) 
.J+l) 
,J+1) 
,  J+l) 
,J+1) 
.J+l) 


*T2 (2) 
»T2(2) 
»T2(2) 
»T2(3) 
*T2 (3) 
»T2(3) 
*T2  (1) 
»T2(1) 
»T2 ( 1) 


NOTE  THAT  FOR  EACH  JOINT 
A2KM.N)  =  B12IN.M) 


FOR  EACH  JOINT  SET 

V1(J)  =  -D(I)'«W(I)X<  W(I)XSR(2J-1)  ) 

+D (J+l ) ’«W(J+1)X(  W(J+1)XSR(2J) 


CALL  CROSS (WMEG( 1,1) ,T1 ,T) 

CALL  CROSS (WMEG( 1,1) ,T , S) 

CALL  D0T31 (D( 1 , 1 . I) ,S,V1(1,J)) 
CALL  CROSS (WMEG( l.J+l) ,T2,T) 

CALL  CROSS («»MEG{  1 , J+l)  ,T,S) 

CALL  D0T31 (D( 1 . 1 , J+l) ,S,T) 

DO  32  K= 1  , 3 

32  V1(K,J)  =  T (K)  -  V1(K,J) 

IF  (IABSdPIN(J) )  .LT.5)  GO  TO  40 
IF  (IEULER(J) .EQ.-l)  GO  TO  40 
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SLIP 
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SLIP 
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SETUP 1 
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SETUP 1 

SETUP 1 

SETUP 1 

SETUP 1 
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SETUP  1 
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CALL  D0T31 (D ( 1 , 1 , I ) ,HT(1 ,3 ,2»J-1) ,T4) 

CALL  CROSS (WMEG( 1,1) fHT(l ,3,2*J-1) ,T5) 

CALL  DOT31 (D  ( 1 , 1 , 1 ) ,T5,T6) 

V1T  =  VI ( 1 , J) »T4 ( 1 )  +  VI (2 , J) *T4 (2)  ♦  VI (3 . J) *T4 (3) 

SR2  =  2 . 0»SR(4 ,  2*J) 

DO  34  K  =  1,3 

V1(K,J)  =  Vl(K.J)  -  V1T«T4 (K)  -  SR2»T6(K) 

S1=T4 ( 1 ) *B12 ( 1 ,K,2*J- 1) +T4 (2) *B12 (2 ,K,2*J- 1 ) +T4 (3) *B12(3,K, 2*J -1 ) 
S2=T4(1)»B12(1,K,2»J  ) +T4 (2) *B12 (2 ,K , 2»J  ) +T4 (3) *B12 (3 , K , 2»J  ) 

DO  33  L  =  1,3 


A11(K,L,J)  =  -T4 (K) *T4  CL) 

B12 (L , K , 2  »  J - 1 )  =  B12(L,K,2*J-1) 

33  B12 (L,K,2*J  )  =  B12(L,K,2»J  ) 

34  A1KK.K.J)  =  1.0  +  A1KK.K.J) 

40  CONTINUE 

IF  (NPRT(ll) .NE.O)  WRITE  (6,41) 


-  S 1*T4 (L) 

-  S2*T4(L) 


( (VI (I , J) ,1=1,3) , J= 1 , NJNT) 


41  FORMAT ( ’  VI  ARRAY’ / ( IX , 1P9D14 . 4) ) 


IF  IPIN(M) = 1 ,  SET  V2 (M) = ( WN . HN-WM. HM) DN ' WNXHN 


DO  50  J  = 1 , NJNT 
DO  43  K= 1 , 3 

43  V2(K,J)  =  0.0 

IF  (IPIN(J) .LT. 1)  GO  TO  50 
IF  (IPIN(J).GT.l. AND. IPIN(J) .LT.6)  GOTO  50 
I  =  IABS ( JNT (J) ) 

CALL  CROSS  (WMEG(1.I  ) ,HB(1 ,2«J-1) ,T) 

CALL  D0T31  (D< 1 ,1,1  ) ,T,T1) 

CALL  CROSS  ( WMEG ( 1 , J  + 1 ) , H8 ( 1 , 2 » J  ) ,T) 

CALL  D0T31  (D ( 1 , 1 , J+ 1) ,T ,T2) 

51  =  WMEG ( 1 , I ) *HB ( 1 , 2« J- 1 ) 

*  +  WMEG (2 ,I)*HB(2,2*J-1) 

»  ♦  WMEG (3 ,I)*HB(3,2*J-1) 

52  =  WMEG(1,J+1)«HB(1,2*J) 

»  ♦  WMEG (2 ,J+ 1 ) »HB (2 , 2*J) 

*  +  WMEG (3 ,J+1)*HB(3,2*J) 

DO  44  K= 1 , 3 

44  V2 (K , J)  =  S1*T1(K)  -  S2*T2(K) 

44  V2 (K , J)  =  (S1-S2) «T1 (K) 

50  CONTINUE 
98  CALL  ELTIME(2 , 10) 

RETURN 

END 
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SUBROUTINE  SETUP2 


REV  IV 


SETUP2 

07/24/86SLIP 


CALLED  BY  DAUX  AFTER  CONTACT  ROUTINES  AND  BY  UPDATE  PRIOR  TO 
DAUX  TO  SET  UP  A2  ARRAY  AND  (FOR  NQ*0)  THE  A13.A23  AND  V3  ARRAYS. 


SETUP2 

SETUP2 

SETUP2 

SETUP2 

SETUP2 

PAGE 


IMPLICIT  REAL*8(A-H,0-Z)  SETUP2 

COMMON/CONTRL/  TIME, NSEG , NJNT , NPL , NBLT , NBAG , NVEH , NGRND ,  SETUP2 

*  NS , NQ ,NSD , NFLX, NHRNSS , NWINDF .NJNTF ,NPRT (36) ,NPG  PAGE 

COMMON/ SGMNTS/  D(3,3,30) ,WMEG(3,30) ,WMEGD(3,30) ,U1(3,30) ,U2(3,30) , SETUP2 

*  SEGLP(3,30) ,SEGLV(3,30) ,SEGLA(3,30) ,NSYM(30)  SETUP2 

COMMON/DESCRP/  PHI (3,30) ,W(30) ,RW(30) ,SR(4,60) ,HA(3,60) ,HB(3,60) ,  SLIP 

*  RPHI (3,30) ,HT(3,3,60) , SPRING (5 ,90) , VI SC (7 , 90) ,  SETUP2 

«  JNT(30) ,IPIN(30) ,ISING(30) ,IGLOB(30) ,JOINTF(30)  SETUP 2 

COMMON/CMATRX/  Vl(3,30) ,V2(3,30) ,V3(3,12) ,BI2(3,3,60) ,A22(3,3,60) , SETUP2 

*  F(3,30) ,TQ(3,30) ,WJ(30) ,A11(3,3.30)  SLIP 

COMMON/CSTRNT/  A13(3,3,24) ,A23(3,3,24) ,B31 (3,3,24) ,B32(3,3,24) .  SETUP2 

»  HHT(3,3, 12) ,RK1 (3, 12) ,RK2(3, 12) ,QQ(3, 12) ,TQQ(3, 12) , SETUP2 


*  RQQ(3, 12) ,HQQ<3, 12) , SQQ (12) ,CFQQ(I2) , 

*  KQ 1 ( 1 2 ) , KQ2 ( 1 2 ) , KQTYPE (12) 

COMMON/CNSNTS/  PI .RADIAN, G.THIRD.EPS (24) , 

*  UNITL , UNITM.UNITT ,GRAVTY(3) .TWOPI 
LOGICAL# I  FREE 

COMMON/TEMPVS/T (3) ,S(3) ,T1 (3) ,T2(3) ,T3 (3) ,T4(3) ,T5(3) ,T6(3) , 

*  T7 (3) ,T8 (3) ,T9 (3) ,T10(3) .Til (3) ,T12(3) ,HH(3) , 

<  TT1 (3,3) , TT2(3 ,3) ,S1 ,SQS1 ,S2 ,S3 ,S4 

*  ,WCRM(3) ,RM(3) ,WCM(3) ,WWCM(3) ,WWM(3) ,RBA  (3) .BA 

*  , WCRN(3) , RN(3) ,WCN(3) ,WWCN(3) ,WWN(3) , RBAD ( 3 ) 

►  ,IDUM(14290) ,FREE(30) 


CALL  ELTIME (1,26) 


COMPUTE  A22  ARRAY  VIA  DHHPIN  FOR  DAUX2  ROUTINES. 


IF  (NJNT.EQ.O)  GO  TO  50 
DO  49  M= 1 , NJNT 
FREE (M)  =  .TRUE. 

N  =  IABS ( JNT (M) ) 

IF  (N.EQ.O)  GO  TO  49 
IF  (IPIN(M) . EQ.O)  GOTO  49 

IF  (IPIN(M) .GE.2.AND.  IPIN(M) . LE . 5)  GO  TO  49 
FREE (M)  =  .FALSE. 

CALL  DHHPIN (A22 (1,1,2* M— 1 ) ,T,N  ,M,2»M-1) 
CALL  DHKPIN(A22 ( 1 , 1 , 2«M  ) ,T ,M+ 1 , M, 2*M  ) 

49  CONTINUE 


THIS  STATEMENT  IS  NECESSARY  FOR  THE  PROGRAM  TO  RUN  ON  THE 
P&E  FORTRAN  VII  0  (REV  4)  COMPILER 


NNNET  =  IPIN(M) 


SETUP2 

SETUP2 

SETUP2 

TWOPI 

SLIP 

SETUP2 

SETUP2 

SETUP 2 

SETUP2 

SETUP2 

SLIP 

SETUP2 

SETUP2 

SETUP2 

SETUP 2 

SETUP2 

SETUP2 

SETUP2 

SLIP 

SETUP2 

SETUP2 

SLIP 

SLIP 

SLIP 

SETUP2 

SETUP2 

SETUP2 

PECONV 

PECONV 

PECONV 

PECONV 

PECONV 

SETUP2 


m 


m 


SET  UP  A13.A23  AND  V3  ARRAYS  FOR  DAUX33. 


50  IF  (NQ.EQ.O)  GO  TO  98 
DO  70  K= 1 ,NQ 

IF  (KQTYPE(K) .LT.O)  GO  TO  70 
IF  (KQTYPE(K) .EQ.5)  GO  TO  70 
M  =  KQl(K) 

N  =  KQ2 (K) 

IF  (KQTYPE (K) .  EQ.2  .OR.  KQTYPE (K) . EQ . 4)  GO  TO  53 


FOR  KQTYPE  =  1  OR  3 .  SET  HHT  =  I 


DO  52  J=1 ,3 
DO  51  1=1,3 

51  HHT(I.J.K)  =  0.0 

52  HHT(J,J,K)  =  1.0 

IF  (KQTYPE (K) .NE. 6)  GO  TO  61 


FOR  KQTYPE=6 ,  SET  HHT=  I-TT’ 


DO  60  J=1 ,3 
DO  60  1=1,3 

60  HHT(I.J.K)  =  HHT(I.J.K)  -  TQQ(I ,K) *TQQ(J,K) 
GO  TO  61 

53  IF  (KQTYPE (K) .NE. 2)  GO  TO  56 


FOR  KQTYPE=2 ,  COMPUTE  HH  AND  HHT. 


CALL  D0T3 1  (D ( 1 , 1  ,M)  ,RK1(1,K)  ,T1) 

CALL  D0T3 1 (D ( 1 , 1 , N) ,RK2(1,K) ,T2) 

SI  =  0.0 
DO  54  1=1,3 

HH( I )  =  SEGLP ( I , M) +T1 ( I )  -  SEGLP ( I ,N) -T2 ( I ) 

54  SI  =  SI  ♦  HH ( I ) *  *  2 
SQS1  =  DSQRT(Sl) 

DO  55  1=1,3 

HH ( I )  =  HH ( I ) /SQS 1 

55  IF  (DABS ( HH ( I ) ) . LE . EPS ( 12) )  HH(I)  =  0.0 
CALL  D0TT3 1 ( HH , HH . HHT ( 1 . 1 , K ) ) 

56  IF  (KQTYPE (K) . NE. 4 )  GO  TO  61 


FOR  KQTYPE  =  4 .  SET  HHT  =  HHT 


CALL  D0TT31 (HQQ( 1 ,K) .HQQ(l.K) , HHT ( 1 , 1 , K ) ) 


SET  A13 (2K- 1 )  =  HHT 
AND  A13 (2K)  =  -HHT 


61  DO  62  J=1 ,3 
DO  62  1=1,3 
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SETUP2 

SETUP2 

SETUP2 

SETUP2 

SETUP2 

SETUP2 

SETUP2 

SETUP2 

SETUP2 

SETUP2 

SETUP2 

SETUP2 

SETUP 2 

SETUP2 

SETUP 2 

SETUP2 

SETUP2 

SETUP2 

SETUP2 

SETUP 2 

SETUP2 

SETUP2 

SETUP2 

SETUP2 

SETUP 2 

SETUP2 

SETUP2 

SETUP2 

SETUP2 

SETUP2 

SETUP2 

SETUP2 

SETUP2 

SETUP2 

SETUP2 

SETUr2 

SETUP2 

SETUP2 

SETUP2 

SETUP2 

SETUP2 

SETUP2 

SETUP2 

SETUF 

SETT  2 

SETUP2 

SETUP 2 

SETUP2 

SETUP2 
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A13  (I , J ,  2*K- 1 )  = 
62  A13(I,J.2*K  )  = 


HHT ( I ,  J  ,  X) 
-HHT(I,J,K) 


SET  A23(2K-1)  =  (R1X) (D1 ) A13 <2K- 1 ) 
AND  A23(2K)  =  (R2X) (D2) A13 (2K) 


CALL  MAT33 (D ( 1 , 1 ,M) . A13 ( 1 . 1 ,2*K-1) ,TT1) 

CALL  MAT33 (D(1,1,N) ,A13(1,1, 2*K  ) ,TT2) 

DO  63  J=1 ,3 

CALL  CROSS (RK1 ( 1  ,K) , TT1 ( 1 , J) , A23 ( 1 , J , 2«K- 1 )  ) 
63  CALL  CROSS (RK2 ( 1 ,K) ,TT2 ( 1 ,J) ,A23 ( 1 ,J , 2»K  )  ) 

IF  (KQTYPE (K) . EQ. 4)  GO  TO  72 


FOR  KQTYPE  =  1,2  OR  3,  SET  B31  =  A13’  AND  B32  = 


DO  71  1=1,3 
DO  71  J=1 ,3 
B31  (I ,J,2*K-1) 
B31  (I , J ,2*K  ) 

B32 (I , J , 2*K- 1) 
71  B32 (I , J , 2*K  ) 

GO  TO  76 


A13 ( J , I , 2»K- 1) 
A13 ( J , I , 2*K  ) 

A23 ( J , 1 , 2  *K— 1 ) 
A23 ( J , I ,  2*K  } 


FOR  KQTYPE  =  4.  SET  B3K2K-1)  =  HTT 

B31(2K  )  =  -HTT 

B32  =  (B31)  (D’)  (RX)  ’ 


72  CALL  DOTT3 1 (HQQ ( 1 ,K) ,TQQ ( 1 , K) , B31 ( 1 , 1 , 2*K- 1 ) ) 

DO  73  1=1,3 

DO  73  J  = 1 , 3 

73  B31  ( I ,  J , 2*K)  =  -B31 (I , J , 2 » K- 1 ) 

CALL  DOTT33 (D ( 1 , 1 , M) . B3 1 (1.1 ,2*K-I) ,B32 ( 1 , 1 , 2*X- 1 ) 1 
CALL  DOTT33 (D ( 1 , 1 , N) , B3 1 ( 1 , 1 , 2»K  ) , B32 ( 1 , 1 , 2«K  )) 

DO  74  J= 1 , 3 

CALL  CROSS (RK1 (1 ,K) , B32 ( 1 , J , 2*K- 1 ) , TT 1 ( 1 . J ) ) 

74  CALL  CROSS (RK2 ( 1 ,X) ,B32(1,J,2*K  ) , TT2 Cl , J) ) 

DO  75  1=1,3 

DO  75  J=1 ,3 

B32 ( I  , J , 2»K- 1 )  =  TT1 (J,I) 

75  B32 ( I , J , 2*K  )  =  TT2(J,I) 


COMPUTE  V3  =  D2 ' (W2X(W2XR2) )  -  D1 ’ (WIX(WIXRI) ) 


76  CALL  CROSS (WMEG( 1 ,M) ,RK1 ( 1 , K) ,T3) 


CALL  CROSS 
CALL  DOT 3 1 


CALL  CROSS 
CALL  CROSS 


CALL  DOT31 


(WMEG( 1 ,M) ,T3,T4) 

(D ( 1 , 1 , M) ,T4 ,T5) 

(WMEG(1 ,N) , RK2 ( 1 , X) ,T6) 
(WMEG(l.N) , T6 ,T7) 

(D ( 1 , 1 ,N) ,T7 ,T8) 


DO  64  1=1,3 
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SETUP2 
SETUP2 
SETUP2 
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SETUP2 
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SETUP2 
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SETUP2 
SETUP2 
SETUP2 
SETUP2 
SETUP2 
SETUP2 


64  V3 ( I , K)  =  T8 ( I )  -  T5 ( I )  SETUP2 

IF  (KQTYPE (K) . NE . 2)  GO  TO  67  SETUP2 

SETUP2 

RECOMPUTE  V3  FOR  KQTYPE=2 .  SETUP2 

SETIP2 

CALL  DOT31  (D(l , 1 ,M) .T3.T9  )  SETUP2 

CALL  DOT31  (D( 1 . 1 ,N) ,T6 ,T10)  SETUP2 

52  =  0.0  SETUP2 

DO  65  1=1,3  SETUP2 

TIKI)  =  SEGLV(I  ,M)  +T9(I)  -  SEGLV(I  ,  N)  -TIO(I)  SETUP2 

65  S2  =  S2  +  Til ( I ) * *2  SETUP2 

53  =  HH(1) *V3 (1 ,K)  +  HH(2) «V3 (2 ,K)  +  HH(3) «V3 (3 ,K)  SETUP2 

54  =  S3-S2/SQS 1  SETUP2 

DO  66  1=1,3  SETUP2 

66  V3 (I ,K)  =  S4«HH(I)  SETUP2 

67  IF  (KQTYPE(K) .ME. 3. AND. KQTYPE (K) .NE.6)  GO  TO  77  SETUP2 

SETUP2 

FOR  KQTYPE=3  OR  6,  ADD  R  DOT  TERM  FROM  PLELP  OR  SEGSEG  TO  V3.  SETUP2 

SETUP2 

DO  68  1=1,3  SETUP2 

68  V3 (I ,K)  =  V3(I,K)  +  RQQ(I.K)  SETUP2 

IF  (KQTYPE (K) .NE.6)  GO  TO  70  SETUP2 

SETUP2 

FOR  KQTYPE=6 ,  SET  V3  =  (I-TT’ ) (V3+RQQ)  SETUP2 

SETUP2 

VQQ  =  V3 ( 1 , K) *TQQ( 1 ,K)  ♦  V3 (2 ,K) »TQQ(2 ,K)  ♦  V3(3,K) *TQQ(3.K)  SETUP2 

DO  69  1=1,3  SETUP2 

59  V3 (I , K)  =  V3(I,K)  -  VQQ«TQQ(I,K)  SETUP2 

77  IF  (KQTYPE (K) .NE.4)  GO  TO  70  SETUP2 

SETUP2 

FOR  KQTYPE  =  4,  ADD  R  TERM  FROM  PLELP  OR  SEGSEG  TO  V3.  SETUP2 

SETUP2 

53  =  TQQ ( 1 , K) *V3 ( 1 . K)  ♦  TQQ(2 , K) »V3 (2 ,K)  +  TQQ(3,K)*V3(3,K)  SETUP2 

54  =  S3+SQQ (K)  SETUP2 

DO  78  1=1,3  SETUP2 

78  V3 (I , K)  =  S4*HQQ(I ,K)  SETUP2 

70  CONTINUE  SETUP2 

SETUP2 

SPECIAL  SETUP  FOR  TENSION  ELEMENTS  (KQTYPE  =  5) .  SETUP2 

SETUP2 

N  =  0  SETUP2 

79  N  =  N+l  SETUP2 

IF  (N.GE.NQ)  GO  TO  98  SETUP2 

IF  (KQTYPE (N) .NE. 5)  GO  TO  79  SETUP2 

DO  81  1=1,3  SETUP2 

DO  80  J= 1 , 3  SETUP2 

A 1 3 ( I . J , 2*N- 1 )  =0.0  SETUP2 

A13 (I , J , 2*N  )  =  0.0  SETUP2 

A23(I , J,2*N  )  =  0.0  SETUP2 

B31 (I , J , 2*N- 1 )  =0.0  SETUP2 


c 


o 


B31 (I ,  J,2*N  )  = 

A13 ( I ,J,2«N+1)  = 
A 1 3 ( I , J,2#N+2)  = 
A23(I . J,2»N+1)  = 
B31 (I ,J.2»N+1)  = 
B31  (I ,J,2*N+2)  = 
HHT (I ,  J ,  N  )  = 

80  HHT ( I , J ,N+ 1  )  = 

A 1 3 ( I , I ,2*N-1)  = 
B31 (I .1 ,2*N-1)  = 
B31 ( I , I , 2*N  )  = 

A13 ( I , I , 2*N+2)  = 
B31 (1,1, 2«N+ 1)  = 

81  B31 (I, I ,2«N+2)  = 
N1  =  KQ1 (N) 

N2  =  KQ2 (N) 

DO  82  K=  1 , 3 
CALL  CROSS  (RKK1 

82  CALL  CROSS ( RK2 ( 1 
DO  83  1=1,3 

DO  83  J=1 , 3 
B32 ( I , J , 2*N- 1 )  = 
B32 ( I , J , 2»N  )  = 

B32 ( I , J , 2*N+ 1 )  = 

83  B32 (J , J , 2*N+2)  = 
CALL  CROSS (WMEG( 
CALL  CROSS (WMEG( 
CALL  DOT3 1 (D ( 1 , 1 
CALL  D0T31 (D(l , 1 
CALL  D0T3 1 (D ( 1 , 1 
CALL  DOT31 (D(l , 1 
BA  =  0.0 

DO  84  1=1,3 
RBA  (I)  =  SEGLP ( 
RBAD(I)  =  SEGLV ( 

84  BA  =  BA  +  RBA ( I ) 
BA  =  DSQRT(BA) 
FORCE  =0.0 

IF  (BA. GT . RK2 (3 , 
DO  85  1=1,3 
V3 ( I , V)  =  RK2 (2 , 

85  V3 ( I , N+ 1 )  =  -V3( 
CALL  CROSS (WMEG( 
CALL  CROSS (WMEG( 
CALL  D0T31 (D ( 1 , J 
CALL  D0T31 ( D ( 1 , 1 
DO  86  1=1,3 

V3  ( I , N  )  =  V3(I 

86  V3 (I ,N+ 1 )  =  V3 ( I 
N  =  S*1 


0.0 

0.0 

0.0 

0.0 

0.0 

0.0 

0.0 

0.0 

1.0 

RKKl.M+l) 
RK1 (3 ,N+ 1 ) 
1.0 

RK1 (3 ,N+ 1) 
RK1 (2 ,H+1) 


,W) ,D( 1 ,K,N1) , A23 ( 1 ,K ,2*N- 1 ) ) 
,  N) , D ( 1 , K , N2) , A23 ( 1 , K , 2#N+2) ) 


RK1(1,N+1)*A23(J,I,2*H-1) 
RK1 (3 , N+ 1 ) «A23 ( J , I , 2»H+2) 
RK1 (3 ,N+ 1 ) »A23 (J , I , 2»N- 1 ) 
RK1 (2 ,N+ 1 ) *A23 ( J , I , 2»N+2) 
1  .HI) , RK1 (1 ,H) ,WCRM) 

1.N2)  , RK2 ( 1 , N) , WCRN) 

, N 1 ) , RK1 ( 1 ,N) , RM) 

,N2)  , RK2  ( 1  ,Bf)  ,  RN) 

, N 1 )  , WCRM, WCM) 

,N2)  , WCRN.WCN) 


I.N2)  +  RN  (I)  -  SEGLP(I.Nl) 
I , N2)  +  WCN(I)  -  SEGLV ( I ,N1 ) 
#»2 


RM  (I) 
WCM(I) 


N+ 1 ) )  FORCE  =  RK2 ( 1 ,N+ 1 ) « ( 1 . 0-RK2 (3 ,N+ 1 ) /BA) 

N+ 1 >  *RBAD ( I )  *  F0RCE#RB*(I) 

I ,  N) 

1  ,N1)  , WCRM, WWCM) 

1 ,N2) , WCRN.WWCN) 

,N1 ) , WWCM, WWM) 

,N2) .WWCN.WWN) 

, N  )  -  RK1 ( 1 ,N+ 1) »WWM( I )  -  RK1 (3.N+1) »WWN(I) 
, N+ 1 )  -  RK1(3,N+1)#WWM(I)  -  RK1 (2 ,N+ 1 ) *WWN(I) 
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SETUP2 
SETUP2 
SETUP2 
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GO  TO  79  SETUP2 

98  CALL  ELTIME(2 ,26)  SETUP2 

RETURN  SETUP2 

END  SETUP2 
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SUBROUTINE  SINPUT  SINPUT 

C  REV  IV  02/20/87HYPER 

C  READS  AND  PRINTS  THE  INPUT  CARDS  THAT  DESCRIBE  THE  PHYSICAL  SINPUT 

C  DIMENSIONS  OF  THE  PLANES  REPRESENTING  THE  VEHICLE  PANELS  AND  OF  SINPUT 

C  THE  RESTRAINT  BELTS.  ALSO  PROCESSES  THOSE  DATA  CARDS  THAT  DESCRIBESINPUT 

C  ADDITIONAL  CONTACT  ELLIPSOIDS,  CONSTRAINTS,  BODY  SEGMENT  SYMMETRY  SINPUT 

C  OPTIONS  AND  SPRING  DAMPER  FUNCTIONS.  SINPUT 

C  SINPUT 

IMPLICIT  REAL* 8  (A-H.O-Z)  SINPUT 

COMMON/CONTRL/  T I  ME , NSEG , NJNT , NPL , NBLT , NB AG , NVEH , NGRND ,  SINPUT 

*  NS ,NQ , NSD , NFLX , NHRNSS , NWINDF , NJNTF , NPRT (36) , NPG  PAGE 

COMMON/CNTSRF/  PL (24 , 30) .BELT (20 ,8) ,TPTS (6 ,8) ,BD (24 ,40)  EDGE 

COMMON/ SGMNTS/  D(3,3,30) ,WMEG(3,30) ,WMEGD(3,30) ,U1(3,30) ,U2(3,30) .SINPUT 

*  SEGLP(3,30) ,SEGLV(3,30) ,SEGLA(3,30) ,NSYM(30)  SINPUT 

COMMON/CSTRNT/  A13(3,3,24) ,A23(3,3,24) ,B31 (3,3,24) ,B32(3,3,24) ,  SINPUT 

*  HHT (3 , 3,12) , RK 1 ( 3 , 1 2 ) ,RK2(3,12) ,QQ(3,12) ,TQQ(3,12) .SINPUT 

*  RQQ(3, 12) ,HQQ(3,12) ,SQQ(I2) ,CFQQ(12) ,  SINPUT 

*  KQ1 (12) ,KQ2(12) ,KQTYPE(12)  SINPUT 

COMMON/TITLES/  DATE (3) ,C0MENT(40) ,VPSTTL(20) ,BDYTTL(5) ,  SINPUT 

*  BLTTTL(5,8) ,PLTTL(5,30) ,BAGTTL(5,6) ,SEG(30) ,  SINPUT 

*  JOINT(30) ,CGS(30) ,JS(30)  SINPUT 

REAL  DATE , COMENT , VPSTTL , BDYTTL , BLTTTL , PLTTL , BAGTTL , SEG .JOINT  SINPUT 

LOGICAL* 1  CGS.JS.LP4  HYPER 

COMMON/ DAMPER/  APSDM(3,20) ,APSDN(3,20) ,ASD(5,20) ,MSDM(20) .MSDN (20) SINPUT 
COMMON/ WINDFR/  WTIME (30) ,QFU(3,5) ,QFV(3,5) ,WF(3,30) ,IWIND(30) ,  WINDOP 

*  MWSEG(7.30) ,NFVSEG(6) ,NFVNT(5) ,MOWSEG(30 ,30)  WINDOP 

COMMON/ CNSNTS/  PI , RADIAN , G .THIRD, EPS (24) ,  SINPUT 

»  UNITL,UNITM,UNITT,GRAVTY(3) .TWOPI  TWOPI 

COMMON/TEMP VS/  P i (3) , P2 (3) , P3 (3) , P4 (3) ,DE (3 , 3)  HYPER 

DIMENSION  IDYPR(3)  SINPUT 

DATA  IDYPR/3 ,2,1/  SINPUT 

DATA  MAXBD/40/  CHGIII 

DATA  NPLMAX/30/ .NBLTMX/8/ .NBAGMX/5/ .NELPMX/40/ .NQMAX/12/ ,  MISC 

*  NSDMAX/20/ .NHRNSM/5/ .NWINDM/50/ .NJNTFM/50/ .NFORCM/5/  MISC 

C  SINPUT 

C  INPUT  CARD  L . 1  SINPUT 

C  SINPUT 

READ  (5,11)  NPL , NBLT , NBAG , NELP , NQ , NSD , NHRNSS , NWI NDF , NJNTF , NFORCES I NPUT 
11  FORMAT (1216)  SINPUT 

WRITE  (6,16)  NPG. NPL, NBLT, NB AG, NELP.NQ, NSD, NHRNSS, NWI NDF, NJNTF,  PAGE 

*  NFORCE  PAGE 

NPG=NPG+ 1  PAGE 

16  FORMAT ( ’ 1  NPL  NBLT  NBAG  NELP  NQ  NSD  NHRNSS’ .PAGE 

*  *  NWINDF  NJNTF  NFORCE’ , 43X ,’ PAGE’, 15/ 1018 , 40X, ’CARD  D . 1’ ) PAGE 

IF  ( NPL . GT . NPLMAX)  STOP  65  CHGIII 

IF  (NBLT . GT . NBLTMX)  STOP  66  MISC 

IF  (NBAG. GT . NBAGMX)  STOP  67  MISC 

IF  ( NELP . GT . NELPMX)  STOP  68  MISC 

IF  (NQ.GT.NQMAX)  STOP  69  CHGIII 

IF  (NSD . GT . NSDMAX)  STOP  70  CHGIII 
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IF  (NHRNSS . GT . NHRNSM)  STOP  71 
IF  ( NWI NDF . GT . NWI RDM)  STOP  72 
IF  ( NJNTF . GT . NJNTFM)  STOP  73 
IF  ( NFORCE . GT . NFOBCM)  STOP  74 
IF  (NPL.EQ.O)  GO  TO  15 
I PAGE  =  0 
DO  20  J= 1 ,  NPL 

READ  AND  PRINT  CARDS  D.2.A.D.2.B  AND  D.2.C  FOR  THE  JTH  PLANE. 

READ  (5,23)  JJ , (PLTTL (I , J) , I  =  1 ,5) ,P1 ,P2 ,P3 

23  FORMAT  (I4.4X.5A4/ (3F12.0) ) 

IF  (JJ.NE.J)  WRITE  (6,24)  JJ,J 

24  FORMAT  (’  PLANE  INDEX  INPUT  ERROR, *,214) 

IF  (JJ.NE.J)  STOP  10 

IF  (MOD(J,7) . EQ. 1 .AND. IPAGE.EQ.O)  WRITE  (6,12)  IPAGE 
IF  (MOD(J,7) .EQ.l. AND. IPAGE. EQ.l)  WRITE  (6,112)  IPAGE. NPG 
IF  (MOD(J,7) .EQ.l .AND. IPAGE. EQ. 1)  NPG=NPG+1 
112  FORMAT (II,'  PLANE  INPUTS’ . 109X, ’PAGE ’,15/1 20X, ’CARDS  D.2’) 

12  FORMAT (II,’  PLANE  INPUTS’ , 106X, ’CARDS  D.2’) 

IPAGE  =  1 

WRITE  (6,25)  J,  (PLTTL(I.J) ,1  =  1 ,5) ,P1 ,P2 ,P3 

25  FORMAT ( ’ 0  PLANE  NO. ’ . 14 , 4X, 5A4// 17X, ’X’ , 1 IX, ’ Y’ , 1 IX, ’Z’ / 

*  ’  POINT  1  ’  , 3F12 . 4/ 

*  ’  POINT  2  '  , 3F12 . 4/ 

*  ’  POINT  3  ’  .3F12.4) 

PROGRAM  NOW  ASSUMES  THE  FINITE  PLANE  IS  A  PARALLELOGRAM  IN  SHAPE 
WHERE  THE  INPUT  POINTS  P1.P2.P3  ARE  3  OF  THE  CORNERS  SUCH  THAT 
EDGE  P1-P2  IS  LESS  THAN  180  DEGREES  CLOCKWISE  (AS  VIEWED  BY  THE 
OCCUPANT)  FROM  THE  EDGE  P1-P3. 

SET  UP  PL  ARRAY  AS  REQUIRED  BY  SUBROUTINE  PLELP 


PL(1,J)  =  A( 
PL(2,J)  =  B< 
PL (3 , J)  =  C( 
PL ( 4 , J)  =  D( 

PL(5, J) 

PL (6 , J) 

PL(7 , J) 

PL (8  ,  J)  =A1 
PL (9 , J)  =B1 
PL( 10  .  J) =C1 
PL (11 , J) =D1 
PL ( 12 , J) =E1 

PL( 13 , J) =A2 


NORMAL  EQUATION  OF  JTH  PLACE 
A0»X  +  B0»Y  ♦  C0»Z  =  DO 


POINT  1 


NORMAL  EQUATION  OF  1ST  BOUNDARY  PLANE 
A1»X  +  B1*Y  +  C1*Z  =  D1 
AND  El  IS  LENGTH  OF  PLANE  FROM  BOUNDARY. 


MI  SC 
MI  SC 
MI  SC 
MI  SC 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
PAGE 
PAGE 
PAGE 
PAGE 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
EDGE 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 


$38 

m 

o] 

m 

m3 

I 


WL 

>!*  iJ'j 

* 


PL ( 14 , J) =  B2 
PL ( 15 , J) =C2 
PL( 16 , J) =  D2 
PL ( 17 , J) =E2 

PL ( 18 , J) 

PL ( 19 , J) 

PL (20 , J) 

PL (21 , J) 

PL (22 , J) 

PL (23 , J) 


NORMAL  EQUATION  OF  2ND  BOUNDARY  PLANE 
A2*X  +  B2*Y  +  C2*Z  =  D2 
AND  E2  IS  LENGTH  OF  PLANE  FROM  BOUNDARY. 


POINT 


POINT 


PL(24 , J)  NOT  CU 

522  =  0.0 

523  =  0.0 
S33  =  0.0 

DO  26  I  =1.3 

P2 ( I )  =  P2 (I) -PI (I) 

P3 ( I )  =  P3 (I) —PI  (I) 

PL ( I +  4 . J)  =  Pl(I) 

PL ( I + 17 , J)  =  P2 ( I ) 

PL ( I +20 , J)  =  P3 ( I ) 

522  =  S22  +  P2 ( I ) #P2 (I) 

523  =  S 23  +  P2 (I) *P3 (I) 

26  S33  =  S33  +  P3(I)*P3(I) 

52  =  DSQRT (S22) 

53  =  DSQRT (S33) 

CALL  CROSS (P2,P3,PL(1,J)) 
SI  =  0.0 
DO  27  1=1,3 

27  SI  =  SI  +  PL(I,J)**2 
SI  =  DSQRT (SI) 

DO  28  1=1,3 

PL ( I . J)  =  PL(I,J)/S1 

PL(I+7  ,J)  =  (S33#P2(I)  - 


POINT  3  -  POINT  1 


NOT  CURRENTLY  USED 


28  PL ( I + 12 , J)  =  ( 
PL (  4 , J)  =  PI ( 
PL(ll.J)  =  P 1 ( 
PL ( 12 , J)  =  P2( 
PL ( 16 , J)  =  P 1 < 
20  PL ( 17 , J)  =  P3( 
15  IF  (NBLT.EQ.O) 
DO  30  J  = 1 , NBLT 


=  (S22*P3 ( I )  - 
PI ( 1) *PL(  1 , J) 
PI ( 1) #PL(  8 , J) 
P2 ( 1 ) »PL (  8 , J) 
PI ( 1 ) *PL ( 13 , J) 
P3 ( 1 ) »PL ( 13 , J) 
.0)  GO  TO  35 


S23*P3(I)) 

S23*P2(I)) 


(SI*  S3 ) 
(S1*S2) 


PI (2) *PL (  2 , J) 
PI  (2) *PL(  9 , J) 
P2 (2) *PL (  9 , J) 
PI (2) «PL ( 14 , J) 
P3 (2) *PL ( 14 , J) 


PI (3) *PL (  3 , J) 
PI (3) »PL(10,J) 
P2 (3) *PL ( 10, J) 
PI (3) *PL( 15 , J) 
P3 (3) *PL( 15 ,J) 


READ  AND  PRINT  CARDS  D.3.A,  D.3.B  AND  D.3.C  FOR  THE  JTH  BELT. 

READ  (5,13)  (BLTTTL ( I , J) , I  =  1 , 5) , (BELT ( I , J) , I  =  1,11) 

13  FORMAT  (5A4/ (6F12.0) ) 

IF  (MOD(J ,5) .EQ. 1)  WRITE  (6,21)  NPG 


S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
EDGE 
EDGE 
EDGE 
EDGE 
EDGE 
EDGE 
EDGE 
EDGE 
EDGE 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
EDGE 
EDGE 
EDGE 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
S INPUT 
PAGE 


IF  (M0D(J,5) .EQ. 1)  NPG=NPG  1  PAGE 

21  FORMAT ( ’ 1  BELT  INPUTS’ . 110X, ’PAGE’ .I5/120X, ’CARDS  D.3’)  PAGE 

30  WRITE  (6,14)  J . (BLTTTL(I , J) , I  =  1,5), (BELT (I , J) , I  =  1,11)  SINPUT 

14  FORMAT! ’0  BELT  NO . ’ . 14 . 4X , 5A4//  SINPUT 

*  30X, ’ANCHOR  POINT  A’ ,46X, 'ANCHOR  POINT  B’/  SINPUT 

*  2(16X,’X',19X,’Y’,19X.,Z\3X)/6F20.3//  SINPUT 

»  26X, ’FIXED  POINT  ON  SEGMENT’ ,45X, ’SLACK(+) ’/  SINPUT 

*  16X , ’ X’ , 19X, ’ Y’ ,19X,’Z’ , 17X, ’BLANK’ , 13X, ’ LENGTH! -) ’/5F20.3)  SINPUT 

C  SINPUT 

C  CALL  AIRBG1  ROUTINE  IF  REQUIRED  FOR  AIRBAG  INPUT  SINPUT 

C  SINPUT 

35  IF  (NBAG.NE.O)  CALL  AIRBG1  SINPUT 

IF  (NELP.LE.O)  GO  TO  51  SINPUT 

C  SINPUT 

C  READ  AND  PRINT  CARDS  D.5  FOR  ELLIPSOID  INPUT,  IF  ANY.  SINPUT 

C  NOTE:  NELP  IS  THE  NO.  OF  ELLIPSOIDS  TO  BE  SUPPLIED  HERE,  NOT  THESINPUT 

C  NO.  OF  ELLIPSOIDS  IN  THE  PROGRAM,  SINCE  THE  FIRST  NSEG  SINPUT 

C  ELLIPSOIDS  WERE  SUPPLIED  ON  CARDS  B.2.A  -  B.2.I.  HOWEVER  SINPUT 

C  THEY  MAY  BE  REPLACED  HERE  IF  DESIRED.  SINPUT 

C  SINPUT 

WRITE  (6,41)  NPG , UNITL , UNITL  PAGE 

NPG=NPG+ 1  PAGE 

41  FORMAT ( ’ 1  ADDITIONAL  ELLIPSOID  INPUT’ ,95X, ’PAGE’ , I5/120X,  PAGE 

*  ’CARDS  D.5’/17X,  ’SEMIAXES  ( ’  .  A4  .  ’ )  ’  ,  18X,  ’OFFSET  (\A4,’)\  PAGE 

»  2 OX, ’ROTATION  (DEG) ’ , 15X, 'POWER’/  HYPER 

»  3X, ’NO. ’ ,2 (8X, ’X’ ,8X, ’ Y’ ,8X, ’Z’ ,6X) ,7X, ’YAW' ,7X, ’PITCH’ ,5X,  SINPUT 

*  ’ROLL’//)  SINPUT 

DO  50  MM= 1 , NELP  SINPUT 

READ  (5,42)  M, PI ,P2 . ?3 ,P4  HYPER 

42  FORMAT ( 16 , 9F6 . 0 , 3F4 . 0)  HYPER 

IF  (M.GT.MAXBD)  STOP  63  CHGIII 

C  CHGIII 

C  PREVENT  EXTRA  ELLIPSOIDS  FROM  CHANGING  AIRBAG  ELLIPSOIDS  CHGIII 

C  CHGI I I 

IF  (M. GT. NVEH. AND. M. LT. NGRND)  WRITE  (6,330)  CHGIII 

330  FORMAT !3X, ’THE  EXTRA  CONTACT  ELLIPSOID  NUMBER  IS  THE  SAME  AS  AN  AICHGIII 

»RBAG  ELLIPSOID’)  CHGIII 

IF  (M.GT. NVEH. AND. M.LT. NGRND)  STOP  64  CHGIII 

WRITE  (6,43)  M,P1 ,P2,P3,P4  HYPER 

43  FORMAT (16 , 3 (3X, 3F9 . 3 , 3X) .3F6.0)  HYPER 

CALL  DRCYPR  (DE ,P3 , IDYPR)  SINPUT 

N  =  1  HYPER 

LP4  =  .FALSE.  HYPER 

DO  39  J  -  1,3  HYPER 

39  IF  (P4(J) .GT.2.0)  LP4  =  .TRUE.  HYPER 

IF  (LP4)  N  =  2  HYPER 

DO  46  I  =  1,3  HYPER 

BD (N  , M)  =  PI (I)  HYPER 

BD(N+3,M)  =  P2 (I )  HYPER 

IF  (LP4)  GO  TO  46  HYPER 


DO  45  J= 1 ,3  SINPUT 

SUM1  =0.0  SINPUT 

SUM2  =0.0  SINPUT 

DO  44  L= 1 , 3  SINPUT 

SUM1  =  SUM1  +  DE (L , I ) /PI <L) **2*DE (L, J)  SINPUT 

44  SUM2  =  SUM2  +  DE (L . I ) *P1 (L) »*2*DE (L . J)  SINPUT 

K  =  3*1  +J  +3  SINPUT 

BD (K  , M)  =  SUM1  SINPUT 

45  BD (K+9 , M)  =  SUM2  SINPUT 

46  N  =  N  +  1  HYPER 

IF  ( . NOT. LP4)  GO  TO  50  HYPER 

BD(l.M)  =  -P4 ( 1)  HYPER 

N  =  8  HYPER 

DO  48  J  =  1,3  HYPER 

BD(J+19,M)  =  P4 ( J)  HYPER 

IF  (BD(J+19,M) .EQ.O.O)  BD(J+19,M)  =  BD(20,M)  HYPER 

BD ( J+ 16 ,M)  =  1 . O/BD ( J+ 1 ,M) **2  HYPER 

DO  48  I  =  1,3  HYPER 

BD(N,M)  =  DE(I,J)  HYPER 

48  N  =  N  +  1  HYPER 


BD(23,M)  =  O.i) 

IF  (BD (20 , M) . NE . BD (21 ,M) )  BD(23,M)  =  1.0 
IF  (BD ( 2 1 , M) . NE . BD (22 , M) )  BD(23,M)  =  1.0 
IF  (BD (22 ,M) . NE. BD (20 ,M) )  BD(23,M)  =  1.0 

50  CONTINUE 

READ  AND  PRINT  CARDS  D.6  FOR  CONSTRAINT  INPUT,  IF  ANY. 

51  IF  (NQ.LE.O)  GO  TO  70 
DO  60  K= 1 , NQ 

READ  (5,52)  KQTYPE(K) ,KQ1 (K) ,KQ2(K) . (RK1 (I ,K) , 1=1 ,3) 

*  , (RK2(I,K) ,1=1,3) 

52  FORMAT (316, 6F6.0) 

IF  (K.EQ.l)  WRITE  (6,53)  NPG.UNITL.UNITL 
IF  (K.EQ.l)  NPG=NPG+ 1 

53  FORMAT ( ’ 1  CONSTRAINT  INPUT ’, 105X ,’ PAGE ’, 15/ 120X ,’ CARDS  D.6’/ 

*  ’  TYPE  SEGMENT  SEGMENT  POINT  ON  1ST  SEGMENT  ( ’ , 

»  A4 , ' ) ’ , '  POINT  ON  2ND  SEGMENT  (’,A4,’)’/ 

»  ’  NO.  NO.  1  NO.  2  X  Y  Z 

*  X  Y  Z'//) 

WRITE  (6,54)  KQTYPE(K)  , KQ 1  (K)  ,KQ2(K)  ,  (RKKI.K)  ,1  =  1,3) 

*  . (RK2(I,K) ,1=1,3) 

54  FORMAT (I6,2I9,2(6X,3F9.3)  ) 

60  CONTINUE 

CARD  D . 7  BODY  SEGMENT  SYMMETRY  INPUT 

70  READ  (5,71)  (NSYM(J) , J=1,NSEG) 

71  FORMAT ( 1814 ) 

DO  103  J= 1 , NSEG 


HYPER 

HYPER 

HYPER 

HYPER 

SINPUT 

SINPUT 

SINPUT 

SINPUT 

SINPUT 

SINPUT 

SINPUT 

SINPUT 

SINPUT 

PAGE 

PAGE 

PAGE 

SINPUT 

SINPUT 

SINPUT 

SINPUT 

SINPUT 

SINPUT 

SINPUT 

SINPUT 

SINPUT 

SINPUT 

SINPUT 

SINPUT 

SINPUT 

TGM0D2 


LJ  =  NSYM(J)  TGM0D2 

IF(IABS(LJ) .GT.NSEG)  GO  TO  107  TGMQD2 

IF (LJ)  104.103,105  TGM0D2 

105  LK  =  NSYM(LJ)  TGM0D2 

IF ( I ABS(LK) .GT.NSEG)  GO  TO  107  TGM0D2 

IF(LK.NE.J)  GO  TO  106  TGM0D2 

GO  TO  103  TGM0D2 

104  JJ  =  -J  TGMOD2 

LJ  =  -LJ  TGM0D2 

LK  =  NSYM(LJ)  TGM0D2 

IF ( I ABS(LK) .GT.NSEG)  GOTO  107  TGM0D2 

IF( (LK.NE.JJ) .OB. (NSYM(J) .EQ.JJ))  GOTO  106  TGM0D2 

GO  TO  103  TGM0D2 

106  STOP  96  TGM0D2 

107  STOP  97  TGM0D2 

103  CONTINUE  TGM0D2 

WRITE (6 , 72)  ( J , J  = 1 , NSEG)  SINPUT 

WRITE (6,73)  (NSYM(J) , J-l ,NSEG)  SINPUT 

72  FORMAT ( ' 0  BODY  SEGMENT  SYMMETRY  INPUT’ ,91X. ’CARD  D.7’//  SINPUT 

*  ’  SEG  NO. ' .3014)  SINPUT 

73  FORMAT  CO  NSYM(J)  '  ,3014)  SINPUT 

NSEG1  =  NSEG+1  SINPUT 

DO  74  J=NSEGI , NGRND  SINPUT 

74  NSYM(J)  =  0  SINPUT 

IF  (NSD.LE.O)  GO  TO  90  SINPUT 

C  SINPUT 

C  CARD  D.8  SPRING  DAMPERS  FUNCTION  INPUT.  SINPUT 

C  SINPUT 

DO  79  J=1 ,NSD  SINPUT 

79  READ  (5,80)  MSDM( J) , MSDN (J) , (APSDM( I , J) ,1=1,3) ,  SINPUT 

*  (APSDN(I.J) ,1=1,3) , (ASD(I.J) ,1=1,5)  SINPUT 

80  FORMAT (213, 11F6.0)  SINPUT 

WRITE  (6,81)  UNITL  SINPUT 

81  FORMAT( 'O’ ,5X, ’SPRING  DAMPERS  FUNCTION  INPUT’ ,82X, 'CARDS  D.8 '//SINPUT 

»  18X, 'COORDINATES  OF  ATTACHMENT  POINTS  (’,A4,’)’/  SINPUT 

*  5X. 'SEGMENT' ,9X, 'SEGMENT  M’ ,16X, 'SEGMENT  N’ ,15X,  SINPUT 

»  'SPRING  FORCE  FUNCTION’ ,12X, 'DAMPING  FORCE  FUNCTION’/  AFREVS 

«  ’  NO.  M  N',2(6X,'X’,7X,’Y’,7X,’Z’,2X),7X.’D0’,9X,’A1’.11X.  SINPUT 

«  'A2',13X,’B1',10X,’B2'  //  >  SINPUT 

DO  82  J= 1 ,NSD  SINPUT 

82  WRITE  (6,83)  J , MSDM( J) , MSDN ( J) , ( APSDM( I , J) ,1=1,3) ,  SINPUT 

*  (APSDN(I.J) ,1=1,3) , (ASD(I,J) ,1=1,5)  SINPUT 

83  FORMAT (I3,2I4,2(1X,3F8.2),F11.2,2F12.3,F15.3,F12.3)  SINPUT 

C  SINPUT 

C  CARDS  D . 9  FORCE  AND/OR  TORQUE  FUNCTIONS.  CHGIII 

C  SINPUT 

90  NFVSEG (6) =  NFORCE  SINPUT 

IF  (NFORCE. LE.O)  GO  TO  99  SINPUT 

WRITE  (6,91)  SINPUT 


91  FORMAT  CO’ ,6X, 'FORCE  AND/OR  TORQUE  FUNCTION  INPUTS ’ ,78X, 'CARDS  D. CHGIII 


*9’//.  5X, ' NO . ’ ,  5X, ’ SEG’ ,  5X,’FCN'.  13X.’X’.  9X.’ Y’ ,  9X,’Z*.  CHGIII 

«  13X,’YAW’,  6X. ’PITCH',  6X,’ROLL’  //)  SINPUT 

DO  95  J=  1 , NFORCE  SINPUT 

READ  (5,92)  NFVSEG(J) ,NFVNT(J) ,P1 ,P2  SINPUT 

92  FORMAT  (2I6.6F10.0)  SINPUT 

WRITE  (6,93)  J.NFVSEG(J) ,NFVNT(J) ,P1,P2  SINPUT 

93  FORMAT  (318 .6X.3F10 . 3 ,6X, 3F10 . 3)  SINPUT 

CALL  DRCYPR  (DE , P2 , IDYPR)  SINPUT 

DO  94  1=1,3  SINPUT 

94  QFU(I.J)  =  DE ( 1 , I )  FIXSPT 

95  CALL  CROSS  (PI ,QFU( 1 , J) ,QFV(1 . J) )  SINPUT 

99  RETURN  SINPUT 

END  SINPUT 


m 


SUBROUTINE  SLPLOT  (X,  NX,  XO,  XN,  XL,  XSIZE,  XLAB,  NXLB,  SLPLOT 

*  Y,  NY,  YO,  YN,  YL,  YSIZE,  YLAB,  NYLB ,  SLPLOT 

*  NPTS ,  NYY,  NDY ,  PLAB1 ,  NPLB1,  PLAB2 ,  NPLB2)  SLPLOT 

REV  III. 2  08/08/84REVIII 
SLPLOT 

ARGUMENTS :  SLPLOT 

X (NPTS)  -  ARRAY  OF  NPTS  ABSCISSAS  TO  BE  PLOTTED.  SLPLOT 

Y (NDY, NYY)  -  ARRAY  OF  NPTS*NYY  ORDINATES  TO  BE  PLOTTED.  SLPLOT 

NX. NY  -  POSITIVE  -  NO.  OF  LINEAR  SUBDIVISIONS.  SLPLOT 

NEGATIVE  -  NO.  OF  LOGARITHMIC  DECADES.  SLPLOT 

XO , YO  -  AXES  ORIGINS  (POWER  OF  TEN  IF  NX. NY  NEGATIVE).  SLPLOT 

XN , YN  -  AXES  END  VALUES  (REQUIRED  IF  NX, NY  POSITIVE).  SLPLOT 

XL , YL  -  LENGTH  (INCHES)  OF  X.Y  AXES.  SLPLOT 

XSIZE, YSIZE  -  PAPER  SIZE  (INCHES)  IN  X.Y  DIRECTIONS.  SLPLOT 

XLAB, YLAB  -  X.Y  AXES  LABELS  (ALPHANUMERIC  ARRAYS).  SLPLOT 

NXLB, NYLB  -  NO.  OF  CHARACTERS  IN  X.Y  LABELS.  SLPLOT 

NPTS  -  NO.  OF  POINTS  IN  X  ARRAY  AND  EACH  Y  ARRAY.  SLPLOT 

NYY  -  NO.  OF  Y  ARRAYS  TO  BE  PLOTTED  VS.  X  ARRAY.  SLPLOT 

NDY  -  FIRST  DIMENSION  OF  Y  ARRAY  IN  CALLING  ROUTINE.  SLPLOT 

(NDY  MUST  BE  .GE.  NPTS)  SLPLOT 

PLAB 1 , PLAB2  -  1ST  &  2ND  LINES  OF  PLOT  ID  LABELS  (ALPHANUMERIC) . SLPLOT 
NPLB1.NPLB2  -  NO.  OF  CHARACTERS  IN  PLOT  ID  LABELS.  SLPLOT 

SLPLOT 

NOTE:  PLOTS  WILL  BE  TRUNCATED  AS  FOLLOWS:  SLPLOT 

NX. NY  POSITIVE  -  XO , YO  .LE.  X,Y  .LE.  XN, YN  SLPLOT 

NX, NY  NEGATIVE  -  XO.YO  .LE.  X,Y  .LE.  XN» 10** (-NX) , Y0« 10»* (-NY)  SLPLOT 

SLPLOT 

DIMENSION  X(NPTS) , Y (NDY, NYY) ,XLAB(1) , YLAB ( 1 ) ,PLAB1(1) ,PLAB2(1)  SLPLOT 

SLPLOT 

NOTE:  THIS  ROUTINE  HAS  BEEN  WRITTEN  FOR  THE  PLOTTING  FACILITIES  SLPLOT 

AT  CALSPAN.  THE  FOLLOWING  ITEMS  ARE  KNOWN  TO  BE  CONTRARY  TO  THE  SLPLOT 


NORMAL  CALCOMP  PROCEDURES  AND  SHOULD  BE  EXAMINED  BY  USERS  AT  OTHERSLPLOT 


COMPUTER  SYSTEMS  AND  CHANGES  MADE  ACCORDINGLY.  SLPLOT 

SLPLOT 

1.  AT  CALSPAN  THE  PLOTTED  CHARACTERS  GENERATED  BY  SUBROUTINE  SLPLOT 

SYMBOL  HAVE  A  WIDTH  OF  6/7  TIMES  THE  HEIGHT.  FOR  THE  CALCOMP  SLPLOT 
ROUTINES  THE  WIDTH  IS  EQUAL  TO  THE  HEIGHT.  THE  STATEMENT  SLPLOT 

' WIDTHF  =  6. 0/7.0*  SHOULD  BE  CHANGED  TO  ’ WIDTHF  =  1.0*.  SLPLOT 

SLPLOT 

2.  THE  ONLY  INITIALIZATION  REQUIRED  AT  CALSPAN  IS  THE  STATEMENT  SLPLOT 
’CALL  PLOT  (0.0, 0.0,0)’  TO  ESTABLISH  A  NEW  PAGE,  INCLUDING  SLPLOT 


THE  FIRST  PAGE.  THIS  IS  FOLLOWED  BY  'CALL  PLOT  (XO.YO, -3)’  TOSLPLOT 
SET  THE  PLOT  ORIGIN  ON  THE  PAGE.  PROPER  PLOT  INITIALIZATION  SLPLOT 
SHOULD  BE  DONE  HERE  AND  IN  SUBROUTINE  POSTPR  (AFTER  STATEMENTSLPLOT 
NO.  30)  AS  REQUIRED  BY  THE  USER’S  PLOTTING  FACILITY.  SLPLOT 

SLPLOT 

3.  THE  STATEMENT  ’CALL  NEWPEN(2) ’  SHOULD  BE  EXAMINED  OR  DELETED . SLPLOT 

SLPLOT 

4.  THE  STATEMENT  'CALL  EFPLOT ’  AFTER  STATEMENT  NO.  50  IN  POSTPR  SLPLOT 
IS  REQUIRED  AT  CALSPAN  TO  CLOSE  OUT  THE  PLOT  FILES.  THIS  SLPLOT 


SHOULD  BE  CHANGED  TO  CONFORM  TO  THE  REQUIREMENTS  OF  THE 
USER’S  PLOTTING  FACILITIES. 


5.  THE  NECESSARY  JOB  CONTROL  LANGUAGE  FOR  PLOTTING  IS  NECESSARY 


6.  THE  ONLY  CALCOMP  ROUTINES  NEEDED  ARE  SYMBOL,  NUMBER  AND  PLOT 


LOGICAL  NXPOS , NXNEG , NYPOS , NYNEG 
DATA  HN/0.07/ ,  HL/0. 105/ 

WIDTHF  =  1.0 
WN  =  WIDTHF *HN 
WL  =  WIDTHF*HL 

»»  PLOT  PAGE  INITIALIZATION 
CALL  PLOT  (0.0, 0.0. -3) 

XP  =  0 . 5* (XSIZE- (XL-0 . 5) ) 

YP  =  0 . 5» (YSIZE- (YL- 1 .0) ) 

CALL  PLOT  ( XP , YP , - 3 ) 

NXPOS  =  NX.GT.O 
NXNEG  =  NX.LT.O 
NYPOS  =  NY.GT.O 
NYNEG  =  NY.LT.O 

**  PLOT  AXES  AND  ID  LABELS. 
XP  =  0.0 
YP  =  0.0 

IF  (  NOT . NXPOS)  GO  TO  12 
*»  LINEAR  X  AXIS 

CALL  LINAXS  (XP,  YP ,  0.0,  NX,  XL) 
XB  =  XL/ (XN-XO) 

**  LINEAR  X  AXIS  NUMERICS 
DX  =  XL/FLOAT (NX) 

EX  =  XO 

DD  =  (XN-XO) /FLOAT (NX) 

ND  =  0.99  -  AL0G10 (ABS (DD) ) 


IF  (ND.LE.O)  ND  = 
IX  =  0 

YC  =  YP  -  2 . 0*HN 
AX  =  ABS (EX) 

NF  =  0 

IF  (AX. GE. 10.0)  NF 
NS  =  0 

IF  (EX.LT.O.O)  NS 

SP  =  N3+NF+2+ND 
XC  =  XP  -  0.5*SP«WN 


=  ALOGIO(AX) 


CALL  NUMBER  (XC.  YC .  HN,  EX,  0.0,  ND) 


XP  +  DX 
EX  ♦  DD 
IX  +  1 

( ABS ( EX)  . GT . ABS (0 . 1  *  DD ) ) 
(IX.GT.NX)  GO  TO  12 


GO  TO  18 


CALL  PLOT  (XP,  YP+YL.3) 


SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

REDIMN 

SLPLOT 

SLPLOT 

SLPLOT 

CHANGE 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 


'VwVWVvY 


CALL 
18  IF 
12  IF 


DX  = 
EX  = 
IX  = 
13  CALL 
CALL 


PLOT  (XP,  YP  ,2) 

(IX.LE.NX)  GO  TO  11 
( . NOT.NXNEG)  GO  TO  14 
*»  LOG  X  AXIS  «* 

LOGAXS  (XP.  YP.  0.0,  -NX.  XL) 

XL/ALOG( 10 . 0** (-NX) ) 

-XB«ALOG(XO) 

»*  LOG  X  AXIS  NUMERICS  «* 

XL/ FLOAT (-NX) 

ALOGIO(XO) 

0 

NUMBER  (XP-1 . 0*WN,  YP-2.5»HN,  HN,  10.0.  0.0,  -1) 
NUMBER  (XP+1 .0»WN,  YP-2.0*HN,  HN.  EX.  0.0,  -1) 


GO  TO  13 
GO  TO  15 


SYMBOL (XPX,  YPX ,  HL.  XLAB ,  0.0,  NXLB) 


XP  = 

XP  ♦ 

DX 

EX  = 

EX  + 

1.0 

IX  = 

IX  - 

1 

IF 

(IX. GE 

NX) 

IF 

(NXLB. 

LE.O) 

*« 

X 

XPX 

=  (XL- 

FLOAT 

YPX 

=  YP-4 

.  0»HN 

SLPLOT 

SLPLOT 

SLPLO’’’ 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 

SLPLOT 


15 

IF 

(NPLB1.LE.0)  GO  TO  16 

SLPLOT 

C 

«*  PLOT  LABEL  -  1ST  LINE 

«« 

SLPLOT 

XP1 

=  (XL-FLOAT(NPLBl) *WL) /2.0 

SLPLOT 

YP  1 

=  YP-4.0*HN-4.0*HL 

SLPLOT 

CALL 

SYMBOL  (XP1,  YP1 ,  HL,  PLAB1, 

0.0, 

NPLB1) 

SLPLOT 

16 

IF 

(NPLB2.LE.0)  GO  TO  20 

SLPLOT 

c 

««  PLOT  LABEL  -  2ND  LINE 

*« 

SLPLOT 

XP2 

=  (XL-FL0AT(NPLB2)*WL)/2.0 

SLPLOT 

YP2 

=  YP-4 . 0»HN-6 . 0*HL 

SLPLOT 

CALL 

SYMBOL  (XP2.  YP2 ,  HL,  PLAB2 , 

0.0, 

NPLB2) 

SLPLOT 

20 

XP  = 

0.0 

SLPLOT 

c 

»»  COMPLETE  AXIS  GRID 

*« 

SLPLOT 

IF 

(NYPOS)  CALL  LINAXS  (XL,  YP, 

90.0, 

NY, 

YL) 

SLPLOT 

IF 

(NYNEG)  CALL  LOGAXS  (XL,  YP , 

90.0, 

NY, 

YL) 

SLPLOT 

IF 

(NXPOS)  CALL  LINAXS  (XL  , YL , 

180.0, 

NX, 

XL) 

SLPLOT 

IF 

(NXNEG)  CALL  LOGAXS  (XL  , YL, 

180.0, 

-NX, 

-XL) 

SLPLOT 

IF 

(.NOT. NYPOS)  GO  TO  22 

SLPLOT 

c 

**  LINEAR  Y  AXIS 

«« 

SLPLOT 

CALL 

LINAXS  (XP,  YL,  -90.0,  NY, 

YL) 

SLPLOT 

YB  = 

YL/ (YN-YO) 

SLPLOT 

c 

»»  LINEAR  Y  AXIS  NUMERICS 

«* 

SLPLOT 

DY  = 

YL/FLOAT(NY) 

SLPLOT 

EY  = 

YO 

SLPLOT 

DD  = 

(YN-YO) /FLOAT (NY) 

SLPLOT 

ND  = 

0.99  -  AL0G10 (ABS (DD) ) 

SLPLOT 

IF 

(ND .LE.O)  ND  =  -1 

SLPLOT 

IY  = 

0 

SLPLOT 

XC  = 

XP  -  1 . 0»HN 

SLPLOT 

21 

AY  =  ABS(EY) 

SLPLOT 

NF  =  0 

SLPLOT 

IF  (AY. GE. 10.0)  NF  =  ALOGIO(AY) 

SLPLOT 

NS  =  0 

SLPLOT 

IF  (EY.LT.O.O)  NS  =  1 

SLPLOT 

SP  =  NS+NF+2+ND 

SLPLOT 

YC  =  YP  -  0. 5*SP#WN 

SLPLOT 

CALL  NUMBER  (XC.  YC,  HN,  EY,  90.0,  ND) 

SLPLOT 

YP  =  YP  +  DY 

SLPLOT 

EY  =  EY  +  DD 

SLPLOT 

IY  =  IY  +  1 

SLPLOT 

IF  (ABS(EY) . GT. ABS(0. 1»DD) )  GO  TO  19 

SLPLOT 

IF  (IY.GT.NY)  GO  TO  22 

SLPLOT 

CALL  PLOT  (XP+XL ,  YP ,  3) 

SLPLOT 

CALL  PLOT  (XP  ,  YP,  2) 

SLPLOT 

19 

IF  (IY.LE.NY)  GO  TO  21 

SLPLOT 

22 

IF  ( . NOT . NYNEG)  GO  TO  24 

SLPLOT 

c 

**  LOG  Y  AXIS  »# 

SLPLOT 

CALL  LOGAXS  (XP.  YL,  -90.0,  -NY,  -YL) 

SLPLOT 

YB  =  YL/ALOG( 10 . 0** (-NY) ) 

SLPLOT 

YA  =  -YB*ALOG(YO) 

SLPLOT 

c 

**  LOG  Y  AXIS  NUMEBICS  «» 

SLPLOT 

DY  =  YL/FLOAT(-NY) 

SLPLOT 

EY  =  ALOGIO(YO) 

SLPLOT 

IY  =  0 

SLPLOT 

23 

CALL  NUMBER  (XP-1.0*HN,  YP-1.0»WN,  HN.  10.0, 

90.0, 

-1) 

SLPLOT 

CALL  NUMBER  (XP-1.5»HN,  YP+1.0*WN,  HN,  EY, 

90.0, 

-1) 

SLPLOT 

YP  =  YP  +  DY 

SLPLOT 

EY  =  EY  +  1.0 

SLPLOT 

IY  =  IY  -  1 

SLPLOT 

IF  (IY.GE.NY)  GO  TO  23 

SLPLOT 

24 

IF  (NYLB.LE.O)  GO  TO  25 

SLPLOT 

c 

*»  Y  AXIS  LABEL  «» 

SLPLOT 

XPY  =  XP-4 . 0*HN 

SLPLOT 

YPY  =  (YL-FLOAT (NYLB) *WL) /2 . 0 

SLPLOT 

CALL  SYMBOL (XPY,  YPY,  HL,  YLAB,  90.0,  NYLB) 

SLPLOT 

25 

CONTINUE 

SLPLOT 

c 

*«  PLOT  DATA  ARRAYS  *» 

SLPLOT 

NSYM  =  24 

SLPLOT 

IS  =  NPTS/NSYM 

SLPLOT 

IF  (IS.EQ.O)  IS  =  1 

VARTTH 

XOMIN  =  XO/ 1000.0 

SLPLOT 

YOMIN  =  YO/ 1000.0 

SLPLOT 

DO  40  J  = 1 , NYY 

SLPLOT 

IPEN  =  3 

SLPLOT 

DO  39  1=1, NPTS 

SLPLOT 

XI  =  X2 

SLPLOT 

Y1  =  Y2 

SLPLOT 

IF  (NXPOS)  X2  =  XB*(X(I)  -XO) 

SLPLOT 

IF  ( NYPOS )  Y2  =  YB» (Y(I , J) -YO) 

SLPLOT 

IF  (NXNEG)  X2  =  XA  ♦  XB*AL0G (AMAX1 (X ( I )  .XOMIN))  SLPLOT 

IF  (NYNEG)  Y2  =  YA  ♦  YB» ALOG ( AMAX1 < Y ( I , J) .YOMIN) )  SLPLOT 

IF  (Y2.LT.0.0  .OR.  Y2.GT.YL) 

GO 

TO 

33  SLPLOT 

IF  (X2.LT.0.0  .OR.  X2.GT.XL) 

GO 

TO 

33  SLPLOT 

IF  (IPEN.EQ. 3)  GO  TO  33 

SLPLOT 

CALL  PLOT  (X2.Y2.IPEN) 

SLPLOT 

*»  PLOT  NYSM  SYMBOLS 

*« 

SLPLOT 

IF  (NYY.EQ.l  .OR.  MOD ( I , IS) . NE . 0) 

GO  TO  39  SLPLOT 

IF  (MOD { (I/IS) - 1 ,NYY) + 1 . EQ. J) 

CALL 

SYMBOL  (X2,Y2,0.14,J,0.0,-2)  SLPLOT 

GO  TO  39 

SLPLOT 

33 

IF  (I .EQ. 1)  GO  TO  39 

SLPLOT 

DX  =  X2  -  XI 

SLPLOT 

IF  (DX.NE.O.O)  GO  TO  34 

SLPLOT 

AXO  =  1.0 

SLPLOT 

AXL  =  0.0 

SLPLOT 

IF  (Xl.GE.O.O)  AXO  =  0.0 

SLPLOT 

IF  (Xl.LE.XL  )  AXL  =  1.0 

SLPLOT 

GO  TO  35 

SLPLOT 

34 

AXO  =  -XI  /DX 

SLPLOT 

AXL  =  (XL-XD/DX 

SLPLOT 

35 

AX1  =  AMIN1 (AXO , AXL) 

SLPLOT 

AX2  *  AMAX1 (AXO , AXL) 

SLPLOT 

DY  =  Y2  -  Y1 

SLPLOT 

IF  (DY.HE.O.O)  GO  TO  36 

SLPLOT 

AYO  =  1.0 

SLPLOT 

AYL  *  0.0 

SLPLOT 

IF  (Yl.GE.O.O)  AYO  =  0.0 

SLPLOT 

IF  (Yl.LE.YL  )  AYL  =  1.0 

SLPLOT 

GO  TO  37 

SLPLOT 

36 

AYO  =  -Y1  /DY 

SLPLOT 

AYL  =  (YL-YD/DY 

SLPLOT 

37 

AY1  =  AMIN1 (AYO , AYL) 

SLPLOT 

AY2  =  AMAX  KAYO.  AYL) 

SLPLOT 

A1  =  AMAX1 (AX1 ,AY1 .0.0) 

SLPLOT 

A2  =  AMIN1 (AX2 . AY2 ,1.0) 

SLPLOT 

IF  (A1.GE.A2  )  GO  TO  39 

SLPLOT 

XP  =  XI  +  A1»DX 

SLPLOT 

YP  =  Y 1  +  A1#DY 

SLPLOT 

CALL  PLOT (XP , YP . IPEN) 

SLPLOT 

IPEN  =  2 

SLPLOT 

XP  =  XI  +  A2*DX 

SLPLOT 

YP  =  Y1  ♦  A2«DY 

SLPLOT 

CALL  PLOT (XP , YP , IPEN) 

SLPLOT 

IF  (A2.NE.1.0)  IPEN  =  3 

SLPLOT 

39 

CONTINUE 

SLPLOT 

40 

CONTINUE 

SLPLOT 

RETURN 

SLPLOT 

END 

SLPLOT 
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SUBROUT I NE  SOLVA ( R .  AA  1 1 ,  AA2  2 ,  AA  1 2 ) 


REV  III. 2 


IMPLICIT  REAL»B  (A-H.O-Z) 

DIMENSION  R ( 2 , 3) 

A11=R(1,1)*»2 

A12=2.0«R(2,1)*R(1,1) 

A13=R(2 , 1) »*2 
A21=R( 1 ,2) #*2 
A22=2.0«R(2,2)*R(1 ,2) 

A23=R(2 , 2) *»2 
A31=R( 1 ,3) **2 
A32=2.0»R(2,3)*R(1 ,3) 

A33=R(2 ,3) *»2 

DEL=A1 1* (A22*A33-A23«A32) -A12» (A2 I«A33-A23«A31 ) + 

*  A13«(A21*A32-A22»A31) 

AA 1 1 = ( (A22-A12) * (A33-A23) - (A23-A13) * (A32-A22) ) /DEL 
AA12= ( (A23-A13) * (A31-A21) - (A21-A1 1) « (A33-A23) ) /DEL 
AA22= ( (A2I-A1 1) * (A32-A22) - (A22-A12) » (A31-A21) ) /DEL 
RETURN 
END 


SOLVA 

08/08/84REVIII 

SOLVA 

SOLVA 

SOLVA 

SOLVA 

SOLVA 

SOLVA 

SOLVA 

SOLVA 

SOLVA 

SOLVA 

SOLVA 

SOLVA 

SOLVA 

SOLVA 

SOLVA 

SOLVA 

SOLVA 

SOLVA 


SUBROUTINE  SOLVR(Al , A2 . A3 , A4 , A5 . A6 . A7 , A8 , P ,RX , RZ)  SOLVR 

REV  I I I. 2  08/08/84REVI I I 
IMPLICIT  REAL *8  (A-H.O-Z)  SOLVR 

SOLVR 

xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx  SOLVR 

SOLVR 

THIS  SUBROUTINE  WILL  SOLVE  A  SET  OF  SIMULTANEOUS  EQUATIONS  SOLVR 

TO  FIND  COMPONETS  OF  VECTOR  R  THAT  SATISFY  THE  PROPERTIES  NEEDEDSOLVR 
TO  DETURMI NE  THE  EQUATION  OF  THE  PROJECTED  ELLIPSE.  SOLVR 

SOLVR 

SEE  WRITEUP.  SOLVR 

SOLVR 

xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx  SOLVR 

DIMENSION  P ( 3 )  SOLVR 

B=A1»P(1)+A2*P(2)+A3*P(3)  SOLVR 

D=A4»P(1)+A5*P(2)+A6»P(3)  SOLVR 

T1=A7«(D/B)xx2+A6-2.0*A8»D/B  SOLVR 

T2=2 . 0*A7*D/ (B) »»2-2 . 0*A8/B  SOLVR 

T3=A7x ( 1/B) xx2- 1  SOLVR 

RZ= ( -T2+DSQRT (T2xx2-4 . 0»TI»T3) ) / (2 . 0»TI)  SOLVR 

RX=-D»RZ/B- 1 . O/B  SOLVR 

RETURN  SOLVR 

END  SOLVR 


SUBROUTINE  SPDAMP  SPDAMP 

REV  IV  07/24/86SLIP 

COMPUTES  THE  SPRING  AND  VISCOUS  FORCE  OF  A  SPRING  DAMPER  BETWEEN  SPDAMP 
SPECIFIED  POINTS  ON  SELECTED  SEGMENTS  AND  ADDS  THE  RESULTING  SPDAMP 

FORCE  AND  TORQUE  TO  THE  U1  AND  U2  ARRAYS.  SPDAMP 

SPDAMP 

IMPLICIT  REAL*8 (A-H ,0-Z)  SPDAMP 

COMMON/CONTRL/  T I ME , NSEG , N JNT , NPL , NBLT , NBAG , NVEH , NGRND ,  SPDAMP 

*  NS . NQ , NSD , NFLX , NHRNSS . NWINDF , NJNTF , NPRT (36) , NPG  PAGE 

COMMON/SGMNTS/  D(3,3,30)  ,WMEG(3,30)  ,WMEGD(3,30)  ,U1(3,30)  ,U2(3,30)  .SPDAMP 

»  SEGLP(3,30) ,SEGLV(3,30) ,SEGLA(3,30) ,NSYM(30)  SPDAMP 

COMMON/ DAMPER/  APSDM(3,20) ,APSDN(3,20) ,ASD(5,20) ,MSDM(20) ,MSDN( 20) SPDAMP 
COMMON/TABLES/MXNTI , MXNTB . MXTB1 , MXTB2 , NTI ( 50) , NTAB ( 1 250) , TAB (4500) BUTLER2 
COMMON/FORCES/PSF (7,70) ,BSF(4,20) ,SSF(10,40) ,BAGSF(3,20) ,  NCFORC 

*  PRJNT (7,30) , NPANEL ( 5 ) , NPSF , NBSF , NSSF , NBGSF  SPDAMP 

C0MM0N/TEMPVS/DELM(3) , DELN(3) ,DD(3) ,DEL,T1(3) ,T2(3) ,T3(3) ,T4(3) ,  SPDAMP 

*  DUNIT(3) ,DV(3) ,DMV,DD0,FS,FD,T0TF(3) .  SPDAMP 

*  T5(3) ,T6(3) ,T7(3) ,T8(3)  SPDAMP 

CALL  ELTIME( 1,32)  SPDAMP 

NBSFO  =  NBSF  SPDAMP 

DO  90  1=1. NSD  SPDAMP 

M  «  MSDM(I)  SPDAMP 

N  =  MSDN(I)  SPDAMP 

SPDAMP 

COMPUTE  VECTOR  AND  ITS  MAGNITUDE  BETWEEN  THE  SPECIFIED  POINTS.  SPDAMP 

SPDAMP 

CALL  D0T31  ( D ( I , 1 , M) , APSDM (1,1), DELM)  SPDAMP 

CALL  D0T31  (D ( 1 , 1 ,N) , APSDN (1,1) ,DELN)  SPDAMP 

DEL  =  0.0  SPDAMP 

DO  10  K= 1 ,3  SPDAMP 

DD(K)  =  SEGLP(K.M) +DELM(K) -SEGLP(K.N) -DELN(K)  SPDAMP 

10  DEL  =  DEL+DD (K) *»2  SPDAMP 

IF  (DEL. LE. 0.0)  GO  TO  90  SPDAMP 

DEL  =  DSQRT (DEL)  SPDAMP 

SPDAMP 

COMPUTE  RELATIVE  VELOCITY  AND  ITS  COMPONENT  ON  VECTOR  LINE.  SPDAMP 

SPDAMP 

CALL  CROSS (WMEG( 1 . M) , APSDM ( 1 ,1) ,T1)  SPDAMP 

CALL  CROSS (WMEG( 1 , N) , APSDN ( 1 ,1) ,T2)  SPDAMP 

CALL  D0T31  (D( 1 , 1 ,M) ,T1 ,T3)  SPDAMP 

CALL  D0T31  (D(l , 1 ,N) ,T2 ,T4)  SPDAMP 

DO  20  Kr 1 , 3  SPDAMP 

DUNIT(K)  =  DD (K) /DEL  SPDAMP 

20  DV (K)  =  SEGLV (K , M) +T3 (K) -SEGLV(K , N) -T4 (K)  SPDAMP 

DMV  =  DUNIT(1)*DV(1)+DUNIT(2)*DV(2)+DUNIT(3)*DV(3)  SPDAMP 

SPDAMP 

COMPUTE  SPRING  AND  VISCOUS  FORCE  AND  THE  COMPONENTS  SPDAMP 

ALONG  THE  UNIT  VECTOR  SPDAMP 

SPDAMP 

FS  =  0.0  SPDAMP 


M3 

1 


D 


I 


& 


FD  =  0.0  SPDAMP 

IF  (ASD(l.I) .LT.0.0)  GO  TO  21  SLIP 

DDO  =  DEL-ASD (1,1)  SPDAMP 

IF  (DDO. LE. 0.0  .AND.  ASD (2 , I) . LE. 0 . 0)  GO  TO  41  SPDAMP 

FS  =  DDO* (DABS (ASD (2 , I ) )  ♦  DABS (DDO) »ASD(3 , I ) )  SPDAMP 

FD  =  DMV* (ASD (4 , I) +DABS (DMV) *ASD (5 , I) )  SPDAMP 

GO  TO  29  SPDAMP 

21  DDO  =  DEL+ASD(1 , I)  SPDAMP 

JF1  =  ASD (2 , I )  SPDAMP 

IF  (JF1.EQ.C)  GO  TO  22  SPDAMP 

JF2  =  NTI(JFl)  SPDAMP 

IF  (DDO. GT. 0.0  .OR.  ASD(3,I) .EQ.O.O)  FS  =  EVALFD (DDO , JF2 , 1)  SPDAMP 

22  JF3  =  ASD (4 ,1)  SPDAMP 

IF  (JF3.EQ.0)  GO  TO  29  SPDAMP 

JF4  =  NTKJF3)  SPDAMP 

IF  (DDO. GT. 0.0  .OR.  ASD(3,I) .EQ.O.O)  FD  =  EVALFD (DMV. JF4 . 1)  SLIP 

29  DO  30  K=  1 , 3  SPDAMP 

30  TOTF(K)  =  (FS+FD) *DUNIT (K)  SPDAMP 

SPDAMP 

AND  ADD  THE  RESULTING  FORCE  AND  TORQUE  TO  THE  U1  AND  U2  ARRAYS.  SPDAMP 

SPDAMP 

CALL  MAT31 (D(l , 1 ,M) .T0TF.T5)  SPDAMP 

CALL  MAT31 (D( 1 , 1 ,N) ,TOTF ,T6)  SPDAMP 

CALL  CROSS (APSDM( 1,1) ,T5,T7)  SPDAMP 

CALL  CROSS (APSDNU, I)  .T6.T8)  SPDAMP 

DO  40  K=1 ,3  SPDAMP 

Ul(K.M)  =  Ul(K.M)  -  TOTF(K)  SPDAMP 

Ul(K.N)  =  Ul(K.N)  +  TOTF(K)  SPDAMP 

U2(K,M)  =  U2 (K ,M)  -  T7(K)  SPDAMP 

40  U2 (K.N)  =  U2(K,N)  +  T8(K)  SPDAMP 

41  IBSF  =  3-2*M0D(I ,2)  SPDAMP 

NBSF  =  NBSFO  +  (I  +  D/2  SPDAMP 

BSFdBSF  .NBSF)  =  DEL  SPDAMP 

BSF(IBSF+1 .NBSF)  =  FD  ♦  FS  SPDAMP 

90  CONTINUE  SPDAMP 

CALL  ELTIME(2 ,32)  SPDAMP 

RETURN  SPDAMP 

END  SPDAMP 
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SUBROUTINE  SPLINE  (X.Y.F.N.L) 


SPLINE 

REV  19  05/ 14/79SPLINE 

SPLINE 


ROUTINE  TO  FIT  A  SET  OF  POLYNOMIALS  OF  DEGREE  L 
TO  A  SET  OF  GIVEN  DATA  POINTS  (X(I) ,Y(I) . 1=1 ,N) 


FUNCTION  IS  OF  FORM: 

Y  =  F (2 , K)  +  F (3 ,K) *DX  +  F(4,K)*DX»«2  +  F(5,K)*DX»«3 


WHERE:  DX  =  XX  -  F(l.X) 

F(1,K)  .LE.  XX  .LT.  F(1,K+1)  :  (SETS  K) 

IF  (XX.GT . F ( 1 ,N) )  ;  USE  K=N,  CONSTANT  FIT  TO  Y (N) 
IF  (XX.LT.F(l.l))  ;  EXTRAPOLATED  FIT  FOR  K=1 


F  ( 1 . 1 )  =  X(I)  , 
F  (2 , 1)  =  Y  ( I )  , 


1  =  1. N 

1  =  1  ,N 


DEGREE  L 
0 


0  F(3 , I)  =  F(4 , I)  =  F (5 , I )  =  0  ,  1=1, N  NONE  SPLINE 

1  F (4 , I )  =  F (5 . I )  =  0  ,  1=1, N  Y  SPLINE 

2  F(5 , 1)  =  0  .  1  =  1, N  Y.r  SPLINE 

3  CUBIC  SPLINE  Y.Y*  ,Y”  SPLINE 

SPLINE 

F(X.N) =0  FOB  X=3, 5  IN  ALL  CASES  SPLINE 

SPLINE 

FOR  L=2  AND  L=3  THE  CHANGES  IN  THE  L'TH  DERIVATIVES  ARE  MINIMIZED  SPLINE 

SPLINE 


F(5 , 1)  =  0  . 
CUBIC  SPLINE 


SPLINE 

SPLINE 

SPLINE 

SPLINE 

SPLINE 

*3  SPLINE 

SPLINE 
SPLINE 
SPLINE 

T  TO  Y (N)  SPLINE 

K=1  SPLINE 

SPLINE 
SPLINE 
SPLINE 
SPLINE 

CONTINUITY  SPLINE 

NONE  SPLINE 

Y  SPLINE 

Y.Y’  SPLINE 

Y.Y’.Y”  SPLINE 


F(K.N) -0  FOB  X=3, 5  IN  ALL  CASES 


c 

SPECIAL 

IASES: 

SPLINE 

c 

N=  1 

TREATED  AS  L=0 

SPLINE 

c 

N=2 

TREATED  AS  L=MIN(L,1) 

SPLINE 

c 

L<0 

TREATED  AS  L=0 

SPLINE 

c 

L>3 

TREATED  AS  L=3 

SPLINE 

c 

SPLINE 

c 

STORAGE 

REQUIRED  X (N) , Y(N) , F (5 ,N) ;  SET  BY  CALLING  PROGRAM 

SPLINE 

c 

SPLINE 

c 

USAGE: 

SPLINE 

c 

ALL  COMPUTATIONS  AND  REAL  VARIABLES  ARE  DOUBLE  PRECISION 

SPLINE 

c 

GIVEN: 

L.N.  (X(I) ,Y(I) ,1=1, N) 

SPLINE 

c 

CALL  SPLINE  (X.Y.F.N.L)  ;  SETS  F 

SPLINE 

c 

SPLINE 

CC 

SPLINE 

cc 

TO  EVALUATE  FUNCTION  AND  DERIVATIVES  AT  POINT  XX 

SPLINE 

CC 

SPLINE 

c 

DO 

10  K=  1 ,  N 

SPLINE 

c 

IF 

(K.EQ.N)  GO  TO  11 

SPLINE 

c 

IF 

(XX.LT.F ( 1 ,K+1) )  GO  TO  11 

SPLINE 

c 

10  CONTINUE 

SPLINE 

c 

11  DX 

=  XX  -  F(1,K) 

SPLINE 

c 

YY 

=  F (2 , K)  ♦  DX» (F (3 ,K) +DX» (F (4 ,K) +DX«F (5 , K) ) ) 

SPLINE 

I 


% 

$ 


c 

c 

c 

c 

cc 

cc 

cc 

c 

c 

c 


YD  =  F(3 ,K)  +  DX»(2.0*F(4.K)+3.0*DX*F(5,K)) 
YDD  =  2 . 0*F (4 ,K)  +  6 . 0*DX*F <5 ,K) 

YDDD  =  6 . 0*F (5 , K) 

YDDDD  =0.0 

FUNCTIONAL  VALUE  IN  YY,  DERIVATIVES  IN  YD’S 
REPEAT  FOR  NEXT  VALUE  OF  XX 


AUTHOR:  DR.  JOHN  T.  FLECK 

IMFLICIT  REAL *8  (A-H.O-Z) 

DIMENSION  X ( N) ,Y(N) ,F(5,N) ,C(2,3) 

DO  20  1=1. N 

F(1,I)  =  X(I) 

DO  10  K=2 , 5 

10  F (K , I )  =  0.0 

IF  (L.LT.3)  F (2 . 1 )  =  Y(I) 

20  IF  (L.GT.O  .AND.  I.LT.N)  F (3 , I)  = 

IF  (L.LT.2  .OR.  N.LT.3)  GO  TO  99 
IF  (L.GE.3)  GO  TO  50 
D1  =  X(2)  -  X( 1) 

SS  =  0.0 
DS  =  0.0 
DO  30  1  =  3  ,N 

F(4 , 1-1)  =  F (3 , 1- 1)  -  F (3 , 1-2)  -  F (4 , 1-2) 


(Y(I+1)-Y(I))/(X(I*1)-X(I)) 


SPLINE 

SPLINE 

SPLINE 

SPLINE 

SPLINE 

SPLINE 

SPLINE 

SPLINE 

SPLINE 

SPLINE 

SPLINE 

SPLINE 

SPLINE 

SPLINE 

SPLINE 

SPLINE 

SPLINE 

SPLINE 

SPLINE 

SPLINE 

SPLINE 

SPLINE 

SPLINE 

SPLINE 

SPLINE 


DX1  =  X(I)  -  X(I-l) 

SPLINE 

DX2  =  X(I-l)  -  X ( I  —  2 ) 

SPLINE 

DD  =  D1/DX1  ♦  D1/DX2 

SPLINE 

SS  =  SS  +  DD*DD 

SPLINE 

DS  =  DS  +  DD»(F(4,I-1)/DX1  -  F(4, 1-2) /DX2) 

SPLINE 

'  Mr 

30 

D1  =  -D1 

SPLINE 

F(4 , 1 )  =  DS/SS 

SPLINE 

DX  =  (X (2) -X( 1) ) »F (4 , 1) 

SPLINE 

F (3 . 1 )  =  F (3 . 1 )  -  DX 

SPLINE 

DO  40  1  =  3, N 

SPLINE 

XX  =  F (4 , I- 1 )  -  DX 

SPLINE 

F (3 , 1- 1 )  =  F (3 , 1 - 1 )  -  XX 

SPLINE 

F (4 . 1- 1 )  =  XX/ (X(I) -X(I-l) ) 

SPLINE 

40 

DX  =  -DX 

SPLINE 

S>‘  c 

&  ? 

a. 

GO  TO  99 

SPLINE 

SPLINE 

CUBIC  SPLINE 

SPLINE 

50 

DO  51  1  =  2, N 

SPLINE 

SPLINE 

IF  (I.EQ.N)  GO  TO  51 

SPLINE 

F(4 , 1)  =  3.0»(F(3,I)-F(3,I-1)) 

SPLINE 

::S 

F (5 , I )  =  2.0* ( X ( I ♦ 1 ) -X(I-l) ) 

SPLINE 

51 

F (3 , 1 -  1 )  =  0.0 

SPLINE 

F (2 ,N)  =  -1.0 

SPLINE 

ETC 

F (3 , 1 )  =  -1.0 

SPLINE 

DO  60  1  =  3, N  SPLINE 

DX  =  X(I-l)  -  X( I -2)  SPLINE 

IF  (I.GT.3)  DX  =  DX/F (5,1 -2)  SPLINE 

DO  60  K=3 , 5  SPLINE 

60  F (K . I - 1 )  =  F(K, I- 1) -  F(K, 1-2) »DX»* ( (K- 1 ) / 2)  SPLINE 

DO  70  1=3 , N  SPLINE 

NI  =  N-I  SPLINE 

DX  =  X (NI +3)  -  X(NI+2)  SPLINE 

DO  70  K=2 ,4  SPLINE 

70  F (K.NI+2)  =  (F(K,KI+2)  -  DX»F (K , NI+3) ) /F (5 ,NI+2)  SPLINE 

DO  71  J= 1 , 2  SPLINE 

DO  71  K=J ,3  SPLINE 

C ( J ,K)  =  0.0  SPLINE 

DO  71  1=3, N  SPLINE 

DX1  =  X(I)  -  X(I-l)  SPLINE 

DX2  =  X(I-l)  -  X ( I  —  2 )  SPLINE 

71  C(J,K)  =  C(J,K)  +  (  (F ( J+ 1 , I  ) -F ( J+ 1,1-1)) /DX1  SPLINE 

*  -  (F(J+l.I-l)-F(J+I.I-2))/DX2)  SPLINE 

»  *  (  (F (K+ 1 , I  ) -F (K+ 1,1-1)) /DX1  SPLINE 

*  -  (F(K+l,I-l)-F(K+l,I-2))/DX2)  SPLINE 

DEN  =  C  ( 1 , 1) *C (2 ,2)  -  C ( 1 , 2) »C ( 1 , 2)  SPLINE 

F  (4 , 1 )  =  (C ( 1 , 1 ) »C (2 ,3)  -  C(1,2)*C(1,3)) /DEN  SPLINE 

F (4 , N)  =  (C (2 , 2) *C ( 1 , 3)  -  C  ( 1 ,2)  »C (2 .3) ) /DEN  SPLINE 

DO  72  1=3  N  SPLINE 

72  F (4 , I- I )  =  F(4 , 1- 1 )  -  F(4 , 1 ) *F(3 , 1-1)  -  F(4 .») *F(2 , 1-1 )  SPLINE 

D 1  =  X(2)  -  X( 1)  SPLINE 

F ( 3 , 1 )  =  (Y(2)-Y(1))/D1  -  (2.0*F(4,l)+F(4,2))»Dl/3.0  SPLINE 

F  (2 . 1 )  =  Y ( 1 )  SPLINE 

DO  80  1=2, N  SPLINE 

F (2 , 1 )  =  Y(I)  SPLINE 

DX  =  X ( I )  -  X(I-l)  SPLINE 

IF  (I.LT.N)  F (3 , I)  =  F (3 , I- 1 )  +  (F(4,I)+F (4,1-1)) *DX  SPLINE 

80  F (5,1-1)  =  (F(4,I)-F(4,I-1))/(3.0*DX)  SPLINE 

F (4 ,N)  =  0.0  SPLINE 

99  RETURN  SPLINE 

END  SPLINE 
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DOUBLE  PRECISION  FUNCTION  SPRNGF(T,D, ZD, SPR, JSTOP)  SPRNGF 

REV  IV  07/23/86TWOPI 

COMPUTES  NONLINEAR  SPRING  TORQUE  FOR  JOINTS  AS  A  FUNCTION  OF  ANGLESPRNGF 
ACTUALLY  ROUTINE  RETURNS  TORQUE/ABS (SIN  THETA)  SPRNGF 

SPRNGF 

ARGUMENTS :  SPRNGF 

T  :  COS  THETA  WHERE  THETA  IS  ANGLE  OF  JOINT  (0<THETA<PI)  SPRNGF 

D  :  ABS (SIN  THETA)  SPRNGF 

ZD  :  -THETA  DOT  »  SIN  THETA  SPRNGF 

SPR  :  ARRAY  OF  5  VALUES  DESCRIBING  FUNCTION  EVALUATION  SPRNGF 

JSTOP  :  INDICATOR  TO  BE  SET  TO  ONE  IF  JOINT  IS  IN  STOP  SPRNGF 


IMPLICIT  REAL*8  (A-H.O-Z) 

COMMON/CNSNTS/  PI .RADIAN, G, THIRD, EPS (24) . 

*  UNITL , UNITM , UNITT , GRAVTY (3) .TWOPI 

DIMENSION  SPR(5) 


IF  (Q.GT.I.O)  Q  =  1.0 

IF  (Q.LT.-l.O)  Q  =  -1.0 

X  =  0 . 5* ( 1 . 0+SPR(4)  ♦  Q»(1.0-SPR(4))  ) 

Y  =  0.0 

IF  (D.NE.O.O)  Y  =  Z/D 
Q  =  1.0 

IF  (DABS (Z) . LT . EPS (4) )  Y  =  DSIGN(Q.Z) 

SPRNGF  =  Y»SPR( 1 ) 

JSTOP  =  0 

IF  (SPR (5) .GT.O.O)  GO  TO  10 
SPRNGF  =  X*SPRNGF 
GO  TO  11 

10  IF  (Z.LT.SPR(5) )  GO  TO  11 
JSTOP  =  1 

Z  =  Z-SPR(5) 

SPRNGF  =  SPRNGF  +  X/D» (SPR (2) +Z*SPR(3) ) »Z»»2 

11  CONTINUE 
RETURN 
END 


SPRNGF 

SPRNGF 

SPRNGF 

SPRNGF 

SPRNGF 

SPRNGF 

SPRNGF 

TWOPI 

SPRNGF 

SPRNGF 


m  c 

RESET  T= 1  IF  T>  1 

(HAD  &  HBD  IN  VISPR) 

SPRNGF 

n»  c 

SPRNGF 

IF  (T.GT.1.0)  T  = 

1.0 

SPRNGF 

Cv 

IF  (T.LT.-l.O)  T  = 

-1.0 

SPRNGF 

i  V 

Z  =  DACOS(T) 

SPRNGF 

•  'J 

U  =  EPS ( 1 ) «D 

SPRNGF 

M  - 

Q  =  0.0 

SPRNGF 

m 

IF  (D.NE.O.O)  Q  = 

-ZD/U 

SPRNGF 

SPRNGF 

SPRNGF 

SPRNGF 

SPRNGF 

SPRNGF 

SPRNGF 

SPRNGF 

SPRNGF 

SPRNGF 

SPRNGF 

SPRNGF 

SPRNGF 

SPRNGF 

SPRNGF 

SPRNGF 

SPRNGF 

SPRNGF 

SPRNGF 

SPRNGF 
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SUBROUTINE  TRIGFS  TRIGFS 

REV  19  08/05/78TRIGFS 

IMPLICIT  REAL *8  (A-H.O-Z)  TRIGFS 

COMMON/CDINT/  UU(4) ,GH(3,4) ,  TRIGFS 

*  E(3 .240) ,  F (5 . 240) ,GG(5,240) ,Y(5,240) ,U(5,240) ,  TRIGFS 

»  H.HPRINT ,HS .TPRINT .TSTART, ICNT, IDBL , I FLAG  TRIGFS 

BETA  =0.0  TRIGFS 

IF  (HS.NE.O.O)  BETA  =  (H/HS)**2  TRIGFS 

R I  =  HS/H  TRIGFS 

R2  =  1 . 0+BETA*Rl  TRIGFS 

GH ( 3 , 1 )  =  2 . 0/ (H*R2)  TRIGFS 

GH ( 2 , 1 )  =  GH ( 3 , 1 ) * ( BETA- 1.0)  TRIGFS 

GH(l.l)  =  GH ( 3 , 1 ) *  BETA  TRIGFS 

GH ( 1 .2)  =  4.0*BETA/(R2*H**2)  TRIGFS 

GH ( 3 . 2 )  =  GH ( 1 , 2) *  RI  TRIGFS 

GH (2 , 2)  =  GH(1 . 2)  * (Rl  +  1.0)  TRIGFS 

GH(3 , 3)  =  1.0/H  TRIGFS 

GH(2 ,3)  =  4 . 0*GH(3 ,3)  TRIGFS 

GH ( 1 , 3 )  =  3 . 0*GH(3 ,3)  TRIGFS 

GH ( 3 , 4 )  =  2.0/H**2  TRIGFS 

GH ( 2 , 4 )  =  2 . 0*GH (3 , 4 )  TRIGFS 

GH (1,4)  =  GH ( 3 , 4 )  TRIGFS 

UU(I)  =  2.0/H  TRIGFS 

UU ( 2)  =  0.0  TRIGFS 

UUC3)  =  0 . 5*H  TRIGFS 

UU(4)  =  0.25*H**2  TRIGFS 

IF  (HS.EQ.0.0)  GO  TO  99  TRIGFS 

UU(1)  =  BETA* (4.25+2.25/Rl)  TRIGFS 

UU (2)  =  BETA* (2.25+1.25/R1J/R1  TRIGFS 

UAU  =  1 . 0+UU ( 1 ) +UU(2)  TRIGFS 

UU ( 1 )  =  2 . 0*UU ( 1 ) / (UAU*H)  TRIGFS 

UU(2)  =  4 . 0*UU(2) / (UAU*H**2)  TRIGFS 

99  RETURN  TRIGFS 

END  TRIGFS 


SUBROUTINE  UNITl(IND) 


REV  IV 


UNIT1 

02/20/87HYPER 


THIS  SUBROUTINE  REPLACES  THE  PROGRAM  CODE  THAT  PREVIOUSLY  WAS 
NEAR  THE  END  OF  THE  MAIN  PROGRAM  TO  WRITE  ON  UNIT  1  THAT  DATA 
USED  FOR  VARIOUS  PLOTTING  PROGRAMS  (E.G.  BUBBLE  MAN  PLOT). 

THIS  SUBROUTINE  IS  WRITTEN  TO  GENERATE  UNIT  1  IN  SUCH  A  MANNER 
TO  BE  COMPATIBLE  WITH  THE  INPUT  REQUIREMENTS  FOR  THE  AAMP.L  VIEW 
PROGRAM  THAT  IS  NOW  BEING  DISTRIBUTED  ON  THE  CVS  PROGRAM  TAPES. 

ARGUMENTS : 

IND  =  0:  CALL  IS  FROM  THE  MAIN  PROGRAM 
*  0:  CALL  IS  FROM  SUBROUTINE  EQUILB 

IMPLICIT  REAL»8  (A-H.O-Z) 

COMMON/CONTRL/  TIME, NSEG , NJNT , NPL , NBLT , NBAG , NVEH . NGRND . 

*  NS , NQ , NSD , NFLX , NHRNSS , NWINDF .NJNTF ,NPRT(36) ,NPG 


UNIT1 
UNIT1 
UNIT1 
UNIT  I 
UNIT1 
UNIT1 
UNIT1 
UNIT1 
UNIT1 
UNIT1 
UNIT1 
UNIT1 
UNIT1 
UNIT1 
PAGE 


COMMON/ SGMNTS/  D(3,3.30) ,WMEG<3,30) ,WMEGD(3,30) ,U1 (3 , 30) ,U2 (3 .30) .UNITl 


*  SEGLP (3 , 30) ,SEGLV(3 ,30) ,SEGLA(3,30) ,NSYM(30) 
COMMON/CNTSRF/  PL(24,30) .BELT(20,8) ,TPTS(6,8) ,BD(24,40) 

COMMON/ JBARTZ/  MNPL(  30) ,MNBLT(  8) ,MNSEG(  30) ,MNBAG(  6) 

*  MPL (3 , 5 , 30) , MBLT (3,5,8) ,MSEG(3,5.30) , MBAG (3,10,6) 

*  NTPL (  5,30) ,NTBLT (  5,8),NTSEG(  5,30) 

COMMON/RSAVE/  XSG(3,20,3) .DPMI (3,3,30) ,LPMI (30) , 

*  NSG(9) ,MSG(20,9) ,MCG.MCGIN(24 . 5) ,KREF(20,9) 

COMMON /TEMP VS/  XD(3.3,30) , XSEGLP (3 ,30) ,XPL(17,30) ,XBD(24,40) , 

*  Tl(3) ,T3(3,3) 

REAL  XT I ME , XD , XSEGLP , XPL , XBD 
DATA  IFIRST/O/ 

IF  (NPRT(l) .EQ.O)  GO  TO  99 
IF  (IFIRST.NE.O)  GO  TO  20 
IFIRST  =  I 

FIRST  TIME  IN  ROUTINE,  WRITE  STATIC  DATA  ON  OUTPUT  UNIT  1. 

DATA  MUST  BE  CONVERTED  TO  SINGLE  PRECISION  FOR  VIEW  PROGRAM. 

DO  11  J=  1  ,30 
DO  11  1=1,17 
1 1  XPL (I ,J)  =  PL ( I , J) 

DO  12  J=  1 ,40 
K  =  1 

IF  (BD ( 1 , J) .LT.O.O)  K  =  2 
DO  12  1=1,24 

XBD(I.J)  =  BD(K.J) 

2  K  =  K  ♦  1 

WRITE  (1)  NSEG. NPL, XPL. XBD, MPL 
GOTO  99 

WRITE  TIME  POINT  DATA  ON  OUTPUT  UNIT  1. 

DATA  MUST  BE  CONVERTED  TO  SINGLE  PRECISION  FOR  VIEW  PROGRAM. 


UNIT  1 

EDGE 

UNITl 

UNITl 

UNITl 

UNITl 

TTHKREF 

UNITl 

FIXWBS 

UNITl 

UNITl 

UNITl 

UNITl 

UNITl 

UNITl 

UNITl 

UNITl 

UNITl 

UNITl 

FIXWBS 

FIXWBS 

UNITl 

HYPER 

HYPER 

UNITl 

HYPER 

HYPER 

UNITl 

EDGE 

UNITl 

UNITl 

UNITl 


WvViW-WwV 


20  XT I ME  =  TIME 

DO  22  K= 1 , 30 
DO  22  J=  1 , 3 
DO  21  1=1,3 

21  XDd.J.X)  =  D(I.J.K) 

22  XSEGLP(J.K)  =  SEGLP(J.K) 

DO  25  K= 1 ,NSEG 

IF  (LPMI (K) . EQ.O)  GO  TO  25 
CALL  DOT 3 3  (DPMI ( 1 , 1 ,K) ,D ( 1 , 1 ,K) ,T3) 
DO  24  1=1,3 

DO  24  J=  1 ,3 

24  XD(I,J,K)  =  T3 (I , J) 

25  CONTINUE 

WHITE  (1)  XT I ME , XSEGLP , XD 
99  RETURN 
END 


UNIT1 

UNIT1 

UNIT1 

UNIT1 

UNIT1 

UNIT1 

UNIT1 

UNIT1 

UNIT1 

UNIT1 

UNIT1 

UNIT1 

UNIT1 

UNIT1 

UNIT1 

UNITI 

UNIT1 
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SUBROUTINE  UPDATE(I)  UPDATE 

REV  IV  O7/24/06SLIP 

SUBROUTINE  DINT  UPDATE 

UPDATE 

AT  THE  START  OF  A  NEW  STEP  TO  SETUP  ANY  NEW  CONDITIONS  UPDATE 
TO  BE  VALID  FOR  ENTIRE  INTEGRATION  STEP  UPDATE 

A.  UPDATE  FORCE  DEFLECTION  FUNCTIONS (SUBROUTINE  UPDFDC ) UPDATE 


CALLED  BY  SUBROUTINE  DINT 


(1  =  1) 


B.  TEST  FOR  LOCKED  JOINTS 

NOTE:  ARGUMENT  I  WILL  BE  SET  TO  -1  TO  RESET  INTEGRATOR. 

(1=2)  AT  THE  END  OF  EACH  SUCCESSFUL  INTEGRATION  STEP  TO 

COMPLETE  CALCULATIONS  FOR  OUTPUT  (SUBROUTINE  AIRBG3) 


UPDATE 

UPDATE 

UPDATE 

UPDATE 

UPDATE 

UPDATE 

UPDATE 

UPDATE 

PAGE 


IMPLICIT  REAL*8 (A-H.O-Z)  UPDATE 

COMMON/ CONTRL/  TIME , NSEG , NJNT , NPL , NBLT , NBAG , NVEH , NGRND ,  UPDATE 

*  NS , NQ ,NSD ,NFLX, NHRNSS , NWINDF , NJNTF , NPRT (36) , NPG  PAGE 

COMMON/SGMNTS/  D(3,3,30) ,WMEG(3,30) ,WMEGD(3,30) ,U1(3,30) ,U2(3,30) .UPDATE 

*  SEGLP(3,30) ,SEGLV(3,30) ,SEGLA(3,30) ,NSYM(30)  UPDATE 

COMMON/DESCRP/  PHI  (3 , 30)  ,  WOO)  ,RW(30)  ,SR(4  .60)  ,HA(3 .60)  ,HB  (3 .60)  ,  SLIP 

*  RPHK3.30)  ,HT(3,3,60)  SPRING(5,90)  ,VISC(7.90)  ,  UPDATE 

*  JNT(30) ,IPIN(30) ,ISING(30) ,IGL0B(30) ,JOINTF(30)  UPDATE 
COMMON/CMATRX/  VK3.30)  ,V2(3.30)  ,V3(3, 12)  .B12(3.3,60)  ,A22(3,3,60)  .UPDATE 

»  F(3 , 30) ,TQ(3 , 30) , WJ (30) .All (3,3,30)  SLIP 

COMMON/ JBARTZ/  MNPL(  30) ,MNBLT(  8) ,MNSEG(  30) ,MNBAG(  6),  UPDATE 

*  MPL(3,5,30) ,MBLT(3,5,8) , MSEG (3 , 5 , 30) . MBAG(3 , 10 ,6) ,  UPDATE 

*  NTPL (  5,30) ,NTBLT(  5,8),NTSEG(  5,30)  UPDATE 

COMMON/TABLES/ MXNTI . MXNTB , MXTB 1 , MXTB2 ,NTI (50) , NTAB ( 1 250 ) , TAB ( 4500 ) UPDATE 
COMMON/ FORCES /PSF( 7. 70) ,BSF(4.20) ,SSF(10,40) ,BAGSF(3,20) ,  NCFORC 

*  PRJNT (7,30), NPANEL ( 5 ) . NPSF , NBSF , NSSF . NBGSF  UPDATE 

COMMON/CSTRNT/  A13(3.3,24) ,A23(3.3,24) ,B31(3,3,24) ,B32(3.3.24) .  UPDATE 

*  HHT (3,3,12) ,RK1(3,12) ,RK2(3,12) ,QQ(3,12) ,TQQ(3,12) .UPDATE 


»  RQQ (3 , 12) ,HQQ(3, 12) ,SQQ(12) ,CFQQ(12) , 

»  KQ1(12) ,KQ2 (12) ,KQTYPE(12) 

COMMON/ TEMP VI/  CREST, TTI (3) ,R1I(3) ,R2I(3) , JSTOP (4 , 2 ,30) 
COMMON/CEULER/  IEULER(30) ,HIR(3,3,90) ,ANG(3,30) ,ANGD(3,30) 

*  FE(3,30) ,TQE(3,30) ,C0NST(5,30) 
COMMON/HRNESS/  BAR (15. 100) ,BB(100) .BBDOT(IOO) , PLOSS (2 , 100) 

*  XLONG(20) , HTIME (2) ,IBAR(5,100) ,NL(2,100) , 

»  NPTSPB (20) ,NPTPLY(20) ,NTHRNS(20) ,NBLTPH(5) 

DIMENSION  TQTEST(3) .LOCK (8, 3)  ,T(3) 

DATA  L0CK/-8 ,  6,  5,  7, -3, -2. -4,  I, 

*  6,-8,  4,-3,  7, -1,-5,  2, 

»  5,  4, -8, -2,-1,  7,-6,  3/ 

CALL  AIRBG3  FOR  AIRBAG,  IF  ANY. 

IF  (NBAG.NE.O)  CALL  AIRBG3M) 

IF  (I.EQ.2)  GO  TO  42 
CALL  ELTIME  (1,7) 

IF  (NPL.LE.O)  GO  TO  13 


UPDATE 
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JDRIFT 

JDRIFT 
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CALL  UPDFDC  FOR  EACH  ALLOWED  PLANE-SEGMENT  COHTACT . 

NPSF  =  0 
DO  12  J=1 ,NPL 
NK  =  MNPL(J) 

IF  (NK.LE.O)  GO  TO  12 
DO  11  K  =  1.  NK 
NPSF  =  NPSF+1 
NT  =  NTPL(K.J) 

NF  =  NTAB(NT+5) 

CALL  UPDFDC (NT) 

IF  ( HT . GT . 0 . OR . TAB ( NF+ 3 ) .EQ.0.0)  GO  TO  11 
CALL  IMPULS ( 1 ,K , J) 

I  =  -1 

11  CONTI HUE 

12  CONTINUE 

13  IF  (NBLT.LE. 0)  GO  TO  16 

CALL  UPDFDC  FOR  EACH  ALLOWED  BELT-SEGMENT  CONTACT. 

DO  15  J  = 1 , NBLT 
NK  =  MNBLT(J) 

IF  (NK.LE.O)  GO  TO  15 
DO  14  K  »  l.NX 
NT  =  NTBLT(K.J) 

NF  =  NTAB (NT+5) 

NT6  =  NT+6 
CALL  UPDFDC (NT) 

AND  FOR  2ND  FUNCTION,  IF  FULL  BELT  FRICTION. 

14  IF  (NF.NE.O)  CALL  UPDFDC (NT6) 

15  CONTINUE 

CALL  UPDFDC  FOR  EACH  ALLOWED  SEGMENT-SEGMENT  CONTACT. 

16  NSSF  =  0 

DO  18  J= 1 , NSEG 
NK  =  MNSES(J) 

IF  (NK.LE.O)  GO  TO  18 
DO  17  K  =  l.NK 
NSSF  =  NSSF+1 
NT  =  NTSEG(K.J) 

NF  =  NTAB (NT+5) 

CALL  UPDFDC (NT) 

IF  (NT. GT.O. OR. TAB(NF+3) .EQ.0.0)  GO  TO  17 
CALL  IMPULS (3, K.J) 

I  =  -1 

17  CONTINUE 
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UPDATE 

UPDATE 
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UPDATE 
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UPDATE 

UPDATE 

UPDATE 

UPDATE 

UPDATE 

UPDATE 


18  CONTINUE  UPDATE 

IF  (NHBNSS.LE.O)  GO  TO  71  UPDATE 

UPDATE 

CALL  UPDFDC  FOB  EACH  BELT  OF  HABNESS-BELT  SYSTEMS.  UPDATE 

UPDATE 

CALL  HPTUBB  UPDATE 

J1  =  1  UPDATE 

K 1  =  1  UPDATE 

DO  70  11=1 , NHBNSS  UPDATE 

IF  (NBLTPH(II) . LE.O)  GO  TO  70  UPDATE 

J2  =  J1  +  NBLTPH (II)  -  1  UPDATE 

DO  69  J=J1 , J2  UPDATE 

IF  (NPTPLY(J) .LE.O)  GO  TO  69  UPDATE 

NT  =  NTHBNS(J)  UPDATE 

CALL  UPDFDC (NT)  UPDATE 

K2  =  K1  +  NPTPLY(J)  -  1  UPDATE 

DO  68  K=K1 ,K2  UPDATE 

KI  =  NL(l.K)  UPDATE 

NT  =  IBAB(3 ,XI)  UPDATE 

CALL  UPDFDC (NT)  UPDATE 

68  CONTINUE  UPDATE 

Kl  =  K2+ 1  UPDATE 

69  CONTINUE  UPDATE 

J1  =  J2+ 1  UPDATE 

70  CONTINUE  UPDATE 

71  IF  (NJNT.LE.O)  GO  TO  37  UPDATE 

UPDATE 

CHECK  FOB  IMPULSE  ON  JOINT  STOPS  UPDATE 

TO  BE  CALLED  IF  IN  JOINT  STOP  (JSTOP (1)=1)  THIS  TIME  STEP  UPDATE 

BUT  NOT  IN  IN  JOINT  STOP  (JST0P(2)=0)  AT  PBEVIOUS  TIME.  UPDATE 

UPDATE 

DO  21  K= 1 ,NJNT  UPDATE 

IF  (JNT(K) .EQ.O)  GO  TO  21  UPDATE 

IF  (IABS(IPIN(K)l .NE.4  .AND.  VISC(7,3»X-2) .EQ.O.O)  GO  TO  20  UPDATE 

DO  19  J=1 ,3  UPDATE 

K3J  =  3*X-3+J  UPDATE 

IF  (IABS(IPIN(K)) .NE.4)  K3J=3«K-2  UPDATE 

IF  ( IABS ( IPIN (X) ) . EQ . 4  .AND.  VISC(7,K3J) .EQ.O.O)  GOTO  19  UPDATE 

IF  ( JSTOP ( J , 1 ,K) . NE. 1 .OB. JSTOP ( J , 2 ,K) . NE . 0)  GOTO  19  UPDATE 

CALL  IMPULS(4, J,K)  UPDATE 

I  =  -1  UPDATE 

19  JSTOP ( J , 2 ,K)  =  JSTOP(J.l.K)  UPDATE 

20  IF  (IGLOB(K) .EQ.O)  GO  TO  21  UPDATE 

NT  =  I GLOB (X)  UPDATE 

MT  =  NTAB(NT+5)  UPDATE 

NT1  =  NTAB (NT+2)  UPDATE 

NTAB (NT+2)  =  0  UPDATE 

CALL  UPDFDC (NT)  UPDATE 

NT  =  IABS (NT)  UPDATE 

NTAB (NT*2)  =  NT1  UPDATE 


IF  (TAB (MT+3) . EQ. 0. 0)  GO  TO  21  UPDATE 

IF  (JSTOP(4 , 1 ,K) .NE. I . OR. JST0P(4 ,2 ,K) . NE.O)  GO  TO  21  UPDATE 

CALL  IMPULS (4 , 4 ,K)  UPDATE 

I  =  -1  UPDATE 

21  JSTOP (4 , 2 ,K)  =  JSTOP(4 , 1 ,K)  UPDATE 

UPDATE 

TEST  TO  LOCK  OB  UNLOCK  JOINTS  UPDATE 

UPDATE 

UPDATE 

CONDITIONS  TO  CHANGE  SIGN  OF  IPIN(J)  UPDATE 

UPDATE 

PINNED  UNPINNED  UPDATE 

LOCKED  (-1)  IH.TQ!  >  T1  (-2)  !TQ!  >  T1  UPDATE 

UPDATE 

UNLOCKED  (+1)  ! H . TQ !  <  T2  (+2)  ! TQ !  <  T2  UPDATE 

OB  OB  UPDATE 

WJ  <  T3  WJ  <  T3  UPDATE 

UPDATE 

DO  28  J= 1 , NJNT  UPDATE 

IF  (IABS(IPIN(J) ) . EQ.4)  GO  TO  28  UPDATE 

IF  (IPIN(J) )  22,28,23  UPDATE 

22  T1  =  VISC (4 , 3*J-2)  UPDATE 

IF  (Tl.EQ.O.O)  GO  TO  28  UPDATE 

IF  (IPIN(J) .GT.-l)  GOTO  51  SLIP 

IF  (IPIN(J) .GT. -6. AND. IPIN(J) .LT. -1)  GOTO  51  SLIP 

TQM  *  XDY (HB( 1 , 2*J) , D ( 1 , 1 , J+ 1) , TQ (1 , J) )  UPDATE 

ABSTQM  =  DABS (TQM)  UPDATE 

IF  (ABSTQM. GT.T1)  HA(2,2»J-1)  =  TQM  UPDATE 

TQM  =  ABSTQM  UPDATE 

GO  TO  52  UPDATE 

51  TQM  =  DSQRT(TQ(1 ,J) »»2  +  TQ(2,J)*»2  +  TQ(3,J)»»2)  UPDATE 

IF  (TQM.GT.T1)  CALL  DOT31 (HIB(1 , 1 ,J) , TQ ( 1 , J ) ,HA(1 , 2* J- 1 ) )  UPDATE 

52  IF  (TQM-T1)  28,28,26  UPDATE 

23  T2  =  VISC (5 ,3*J~2)  UPDATE 

IF  (HA (2 , 2 * J ) . NE . 0 . 0)  GO  TO  54  UPDATE 

DO  53  K=  1 ,3  UPDATE 

53  HA(K , 2* J- 1 )  =0.0  UPDATE 

54  IF  (T2.EQ.0.0)  GO  TO  24  UPDATE 

IF  ( IPIN( J) . GE. 2 . AND. IPIN( J) . LE . 5)  SLIP 

»  TQM  =  DSQBT(TQ(1 ,J) **2+TQ(2 , J) *»2*TQ(3 , J) *»2)  SLIP 

IF  (IPIN(J) . EQ. 1 .OR. IPIN(J) .EQ.6.0B. IPIN(J) . EQ.7)  SLIP 

*  TQM  =  DABS (XDY(HB( 1 , 2»J) ,D( 1 , 1 , J+l) ,TQ( 1 , J) ) )  SLIP 

IF  (TQM-T2)  25,28,28  ,  UPDATE 

24  T3  =  VISC (6 , 3»J-2)  UPDATE 

IF  (T3.EQ.O.O)  GO  TO  28  UPDATE 

IF  (WJ(J)-T3)  25,28,28  UPDATE 

25  CALL  IMPLS2(0,J,HB( 1 ,2»J) )  UPDATE 

I  =  -1  UPDATE 

26  IPIN(J)  =  -IPIN(J)  UPDATE 

TMSEC  =  1000 . 0»TIME  UPDATE 


IPINJ  =  -IPIN(J) 

WRITE  (6,27)  TMSEC, J. IPINJ, IPIN(J) 

27  FORMAT ( '0  AT  TIME  =’,F9.3,*  MSEC,  IPIN(’.I2, 

«  ’)  HAS  BEEN  CHANGED  FROM’ ,13,’  TO’, 13) 

28  CONTINUE 

TEST  TO  LOCK  OR  UNLOCK  EULER  JOINTS  AXES. 

USE  SAME  TEST  AS  ABOVE  BUT  ON  EACH  AXIS  SERARATELY. 

IF  LOCK (I EULER, K)  IS  NEGATIVE,  AXIS  K  IS  LOCKED; 

TO  UNLOCK  AXIS  SET  I EULER  TO  - LOCK (I EULER, K) . 

IF  LOCK(IEULER.K)  IS  POSITIVE,  AXIS  K  IS  UNLOCKED; 

TO  LOCK  AXIS  SET  I EULER  TO  LOCK (I EULER, K) . 

DO  36  J  =  1 , NJNT 

IF  (IABS(IPIN(J) ) .NE.4)  GO  TO  36 
JEULER  =  I EULER (J) 

CALL  DOT31 (HIR( 1 . I , J) ,T8(1,J) .TQTEST) 

DO  31  K= 1 , 3 

K3J  =  3*J-3+K 

NLOCK  =  LOCK ( JEULER, K) 

IF  (NLOCK. GT.O)  GO  TO  29 

IF  (VISC(4,K3J) .EQ.0.0)  GO  TO  31 

IF  (DABS (TQTEST (K) ) . LE . VISC (4 , K3J) )  GO  TO  31 

JEULER  =  -NLOCK 

HA(K,2»J-1)  =  TQTEST (K) 

GO  TO  31 

29  IF  (HA(K,2*J) .EQ.0.0)  HA(K,2»J-1)  =  0.0 

IF  (VISC(5,K3J) .EQ.0.0)  GO  TO  30 

IF  (DABS (TQTEST (K) ) . LT. VISC (5 ,K3J) )  JEULER  =  NLOCK 
GO  TO  31 

30  IF  (VISC(6,K3J) .EQ.0.0)  GO  TO  31 

IF  (DABS (ANGD (K , J) ) . LT. VISC (6 ,K3J) )  JEULER  =  NLOCK 

31  CONTINUE 

IF  ( JEULER. EQ. I EULER (J) )  GO  TO  36 

TMSEC  =  1000 . 0»TIME 

WRITE  (6,32)  TMSEC. J.IEULER(J) .JEULER 

32  FORMAT ( ’ 0  AT  TIME  =’,F9.3,’  MSEC,  IEULER(’,I2, 

*  ’)  HAS  BEEN  CHANGED  FROM’, 13,’  TO ’,13) 

IF  (JEULER. EQ. 8)  GO  TO  35 

IF  (IEULER(J) .EQ.7)  GO  TO  35 

IF  (IEULER(J) . EQ.6  .AND.  (JEULER. EQ. 2. OR. JEULER. EQ. 1) )  GOTO  35 
IF  (IEULER(J) .EQ.5  .AND.  (JEULER. EQ. 3. OR. JEULER. EQ. 1) )  GO  TO  35 
IF  (IEULER(J) .EQ.4  .AND.  (JEULER. EQ . 3 .OR. JEULER. EQ. 2) )  GO  TO  35 
MODE  =  -1 
K  =  JEULER 
IF  (K.GT.3)  GO  TO  33 
IF  (K.EQ.2)  GO  TO  34 
K4  =  4-K 
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CALL  CROSS  (HIR(1,K4,J) ,HIR(1,2,J) ,T) 

I EULER (J)  =  8 
IPIN(J)  =  4 
CALL  IMPLS2 (MODE , J , T) 

I  =  -1 
GO  TO  35 

33  MODE  =  1 

K  =  K-3 

IF  (K.GT.3)  M0DE=0 

34  I EULER (J)  =  8 
IPIN(J)  =  4 

CALL  IMPLS2 (MODE , J ,HIR( 1 ,K , J) ) 

I  =  1 

35  IEULER(J)  =  JEULER 
IPIN(J)  =  4 

IF  (IEULER(J) .NE.8)  IPIN(J)  =  -4 

GET  SINE  AND  COSINE  OF  NUTATION  IF  I EULER  GOES  TO  STATE  2 
CALL  EJOINT (- 1 , J) 

IF (JEULER. NE. 2)  GOTO  36 
TQM=  ANG ( 2 . J ) ♦ CONST ( 2 , J ) 

CONST (4 ,J)  =  DCOS(TQM) 

CONST (5 ,J)  =  DSIN(TQM) 

36  CONTINUE 

DO  90  J  =  l.NJNT 
IF  (IABS(IPIN(J)) .LE.4)  GO  TO  90 
IF  (IEULER(J) .GE.O)  GO  TO  90 

IF  (CONST (1,J) .EQ.O.O. AND. CONST (2 , J) .EQ. 0.0)  GO  TO  90 
M  =  JNT(J) 

FTEST  =  XDY (HT ( 1 , 3 , 2*J- 1) , D ( 1 , 1 ,M)  ,F ( 1 , J) ) 

IF  (FTEST. GE.CONST(l.J) .AND. FTEST. LE.C0NST(2, J) )  GOTO  90 
IEULER(J)  =  0 
TMSEC  =  1000.0«TIME 
WRITE  (6,88)  TMSEC, J 

88  FORMAT (/'O  AT  TIME  =’,F9.3,’  MSEC,  JOINT  ’,13,’  HAS  BEEN’, 

*  ’  UNLOCKED  AND  ALLOWED  TO  SLIP.’/) 

90  CONTINUE 

F  IS  THE  FORCE  ON  SEGMENT  Jtl,  -  F  IS  OK  SEGMENT  M 

37  IF  (NQ.LE.O)  GO  TO  41 
DO  40  K=1,NQ 

IF  (KQTYPE(K) .LT.3)  GO  TO  40 
IF  (KQTYPE(K) .GT.4)  GO  TO  40 
IF  (CFQQ(K) .LT.O.O)  KQTYPE(K)  =  -KQTYPE(K) 

IF  (CFQQ(K) .LT.O.O)  GO  TO  39 

TEST  IF  ROLLING  CONSTRAINT  SHOULD  BE  SLIDING  AND  VICE  VERSA. 

QN  =  -XDY (TQQ( I ,K) ,HHT( I , 1 ,K) ,QQ( 1 ,K) ) 

IF  (NPRT (24) . NE . 0)  WRITE  (6,38)  XQTYPE(K) ,KQ1(K) ,KQ2(K) , 

*  (RKKII.K)  ,11  =  1,3)  ,  (RK2  (II  ,K)  ,11  =  1,3)  . 
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«  ((HHT(II.J.K) ,J=1, 3) .11  =  1,3)  ,  UPDATE 

*  (QQ(II,K)  ,11  =  1,3)  ,  (TQQ(II.K) .11=1,3)  ,  (RQQ(II  ,K)  ,  11  =  1 ,3)  ,  UPDATE 

«  (HQQ(II ,K) ,11=1,3) ,SQQ(K) ,CFQQ(K) ,QN  UPDATE 

38  FORMAT ( ’ 0  UPDATE  ROLL-SLIDE  TEST’/(2X,9G14.6) )  UPDATE 

IF  (QN.LT.0.0)  KQTYPE(K)  =  -4  UPDATE 

IF  (QN.LT.0.0)  GO  TO  39  UPDATE 

QDOTQ  =  QQ(1,K)«*2  +  QQ( 2,K)**2  ♦  QQ(3,K)*#2  UPDATE 

QT  =  DSQRT(QDOTQ-QN*»2)  UPDATE 

IF  (KQTYPE(K) .EQ.3  .AND.  QT. LE . CFQQ (K) *QN)  GO  TO  40  UPDATE 

IF  (KQTYPE(K) .EQ.4  .AND.  QT.GE. 0. 9»CFQQ(K ) »QN)  GO  TO  40  UPDATE 

KQTYPE(K)  =  7-KQTYPE(K)  UPDATE 

39  CALL  OUTPUT (0)  UPDATE 

CALL  SETUP2  UPDATE 

CALL  DAUX(K)  UPDATE 

IF  (NPRT (24) . NE . 0)  CALL  OUTPUT(l)  UPDATE 

IF  ( NPRT (  3) .NE.O)  CALL  PRINT  (6HUPDATE)  UPDATE 

I  =  -1  UPDATE 

40  CONTINUE  UPDATE 

41  CALL  ELTIME(2 ,7)  UPDATE 

42  RETURN  UPDATE 

END  UPDATE 


SUBROUTINE  UPDFDC  (M) 

UPDFDC 

c 

REV  III. 2 

08/08/84REVIII 

c 

UPDATE  FORCE  DEFLECTION  CURVE  DEFINITION  THAT  IS 

DEFINED 

UPDFDC 

c 

IN  LOCATION  M  OF  NTAB  ARRAY.  SUBROUTINE  ASSUMES 

THAT 

UPDFDC 

c 

A  SUCCESSFUL  INTEGRATION  STEP  HAS  JUST  BEEN  COMPLETED  AND 

UPDFDC 

c 

WILL  COMPUTE  ENTIRE  CURVE  DEFINITION  TO  BE  VALID 

FOR  NEXT 

STEP. 

UPDFDC 

c 

UPDFDC 

IMPLICIT  REAL»8 (A-H.O-Z) 

UPDFDC 

COMMON/TABLES /MXNT I , MXNTB , MXTB1 , MXTB2 . NT I (50) .NTAB (1250) .TAB (4500) DIMENB 

L  =  NTAB(M) 

UPDFDC 

IF  (L.EQ.O)  GO  TO  99 

UPDFDC 

D  =  TAB(L) 

UPDFDC 

IF  (D.LT.O.O)  D  =  0.0 

UPDFDC 

DLAST  =  TAB (L+ 1) 

UPDFDC 

IF  (D.EQ. DLAST)  GO  TO  99 

UPDFDC 

DCUBIC  =  TAB (L+6) 

UPDFDC 

IF  (D.EQ. DCUBIC)  GO  TO  98 

UPDFDC 

AREA  =  TAB (L+2) 

UPDFDC 

BLAST  -  TAB (L+3) 

UPDFDC 

GLAST  =  TAB(L+4) 

UPDFDC 

DG  =  TAB (L+5) 

UPDFDC 

DGO  =  DG 

UPDFDC 

DREF  =  TAB(L+7) 

UPDFDC 

DMAX  =  TAB (L+8) 

UPDFDC 

DINER  =  TAB (L+9) 

UPDFDC 

FDMAX  =  TAB(L+10) 

UPDFDC 

DCO  =  TAB (L+ 18) 

UPDFDC 

LQ  =  L+ll 

UPDFDC 

LC  =  L+14 

UPDFDC 

IF  (NTAB(M+1) .LT.O)  GO  TO  98 

UPDFDC 

IF  (D-DCUBIC)  10.98,20 

UPDFDC 

c 

UPDFDC 

c 

D  <  DCUBIC.  DEFINE  NEW  CUBIC 

UPDFDC 

c 

Y(X)  =  AO  +  Al» (X-Xl)  +  A2» (X-Xl ) **2  +  A3»(X-X1)»*3 

UPDFDC 

c 

WHOSE  DERIVATIVE  IS 

UPDFDC 

c 

Y'(X)  =  A1  ♦  2*A2* (X-Xl )  +  3»A3+ (X-Xl ) **2 

UPDFDC 

c 

UPDFDC 

10  XI  =  DMAX1  (D ,DG) 

UPDFDC 

X2  =  DREF 

UPDFDC 

c 

UPDFDC 

c 

IF  INERTIAL  SPIKE  EXISTS  AND  IF  DIMAX  <  DREF  .  DROP  INERTIAL  SPIKEUPDFDC 

NI  =  NTAB (M+2) 

UPDFDC 

IF  (NI .GT.O. AND.TAB(NI+3) . GT. 0.0. AND. DREF. GT. TAB (NI+3) ) NTAB (M+2) 

=OUPDFDC 

DX  =  X2-X1 

UPDFDC 

X  =  XI -DG 

UPDFDC 

Y1  =  TAB(LQ)  +X  MTAB(LQ+1)+X  «TAB  (LQ+2) ) 

UPDFDC 

YIP  =  TAB (LQ+ 1 ) +2 . 0»X  »TAB (LQ+2) 

UPDFDC 

X2D0T  =0.0 

UPDFDC 

CALL  FRCDFL  (X2 , X2D0T , M, 0 , Y2P , ELOSS) 

UPDFDC 

CALL  FRCDFL  (X2 .X2D0T.M, 1 , Y2  .ELOSS) 

UPDFDC 

Ufll 


404 


DCUBIC  =  XI  UPDFDC 

DCO  =  DCUBIC  UPDFDC 

UPDFDC 

AO  =  Y(X1)  (THE  VALUE  OF  THE  QUADRATIC  AT  XI)  UPDFDC 

A1  =  Y' (XI)  (THE  DERIVATIVE  OF  THE  QUADRATIC  AT  XI)  UPDFDC 

UPDFDC 

AO  =  Yl  UPDFDC 

A1  =  YIP  UPDFDC 

UPDFDC 

SOLVE  SIMULTANEOUSLY  FOR  A2  AND  A3  UPDFDC 

A2* (X2-X1) **2  +  A3* (X2-X1) **3  =  Y(X2) -AO-A1* (X2-X1)  UPDFDC 

2*A2* (X2-X1)  +  3*A3* (X2-X1) **2  =  Y'(X2)-AI  UPDFDC 

UPDFDC 

RI3  =  (Y2  -  Y1  ~Y1P*DX)/DX**2  UPDFDC 

R23  =  (Y2P  -  YIP) /DX  UPDFDC 

A2  =  3 . 0*R13  -  R23  UPDFDC 

A3  =  (R23  -  2 . 0*R13) /DX  UPDFDC 

UPDFDC 

IF  LOCAL  MINIMUN  OF  CUBIC  (ABSCISSA  VALUE  WHERE  Y’(X)  =  0)  UPDFDC 

LIES  BETWEEN  DCUBIC  AND  DREF  AND  IS  NEGATIVE,  THEN  REPLACE  UPDFDC 

CUBIC  DEFINITION  WITH  STRAIGHT  LINE  BETWEEN  (XI, Yl)  AND  (X2.Y2).  UPDFDC 

UPDFDC 

IF  (A3.NE.0.0)  GO  TO  14  UPDFDC 

R2  =  -0.5*A1/A2  UPDFDC 

GO  TO  15  UPDFDC 

14  A3 3  =  3.0* A3  UPDFDC 

DISC  =  A2*»2-A1*A33  UPDFDC 

IF  (DISC. LT. 0.0)  GO  TO  13  UPDFDC 

SQDISC  =  DSQRT (DISC)  UPDFDC 

R1  =  (-A2+SQDISC) /A33  UPDFDC 

IF  (R1 .LE.0.0.0R.R1 . GE.DX)  GO  TO  11  UPDFDC 

FR1  =  A0+R1* (Al+Rl* (A2+R1*A3) )  UPDFDC 

IF  (FR1.LT.0.0)  GO  TO  12  UPDFDC 

11  R2  =  ( -A2- SQDISC) /A33  UPDFDC 

15  IF  (R2. LE. 0.0. OR. R2. GE.DX)  GO  TO  13  UPDFDC 

FR2  =  A0+R2* (A1+R2* (A2+R2*A3) )  UPDFDC 

IF  (FR2.GE.0.0)  GO  TO  13  UPDFDC 

12  AO  =  Yl  UPDFDC 

A1  =  (Y2-YD/DX  UPDFDC 

A2  =  0.0  UPDFDC 

A3  =  0.0  UPDFDC 

13  TAB (LC)  =  AO  UPDFDC 

TAB (LC+ 1 )  =  A1  UPDFDC 

TAB (LC+2)  =  A2  UPDFDC 

TAB (LC+3)  =  A3  UPDFDC 

TAB (L  +6)  =  DCUBIC  UPDFDC 

TAB (L+ 18)  =  DCO  UPDFDC 

GO  TO  98  UPDFDC 

20  IF  (D-DREF)  21,21,30  UPDFDC 


UPDFDC 


DCUBIC  <  D  <  DREF ,  DEFINE  NEW  QUADRATIC  FROM  CUBIC  CURVE. 
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21  X  =  D-DCO 

Y2  =  TAB(LC) +X* (TAB(LC+1) +X* (TAB(LC+2) +X*TAB(LC+3) ) ) 

XI  =  DCUBIC  -  DG 

AREA  =  XI* (TAB (LQ) +X1* (TAB (LQ+ 1) /2 . 0+Xl*TAB (LQ+2) /3 . 0) ) 

*  +  X* (TAB (LC) +X* (TAB (LC+ 1 ) /2 . 0+X* (TAB (LC+2) /3 . 0+X*TAB (LC+3) /4 
X  =  DCUBIC  -  DCO 

IF  (X.NE.O.O)  AREA  =  AREA 

*  -  X* (TAB (LC) +X* (TAB(LC+ 1 ) /2 . 0+X* (TAB (LC+2) /3 . 0+X*TAB (LC+3) /4 
GO  TO  31 


DREF  <  D,  DEFINE  NEW  QUADRATIC  FROM  BASE  CURVE. 


IF  DINER  <  D  ,  REMOVE  INERTIAL  SPIKE 


30  IF  (NTAB(M+2) .GT.O  .AND.  D.GE. DINER)  NTAB (M+2)  =  0 
NR  =  NTAB (M+3) 

RLAST  =  1.0 

IF  (NR. GT.O  )  RLAST  =  EVALFD(D,NR, 1) 

IF  (RLAST. NE. 1.0)  GO  TO  39 


R  =  1.  USE  BASE  CURVE  FOR  UNLOADING 


DG  =  0.0 
DCUBIC  =0.0 
DREF  =0.0 
AO  =  0.0 
A1  =  0.0 
A2  =  0.0 
GO  TO  32 

39  NG  =  NTAB ( M+  4 ) 

GLAST  =0.0 

IF  (NG.GT.O  )  GLAST  =  EVALFD (D ,NG , 1 ) 
NB  =  NTAB (M+ 1 ) 

DO  =  TAB (NB) 

DG  =  DO  +  GLAST* (D-DO) 

Y2  =  EVALFD (D.  NB.l) 

NI  =  NTAB (M+2) 

IF  (NI.GT.O)  Y2  =  Y2+EVALFD (D ,NI , 1 ) 
AREA  =  EVALFD (D , NB , 2) 

DREF  =  D 
31  DCUBIC  =  D 
XI  =  DG 
X2  =  D 
DX  =  X2-X1 
Y1  =  0.0 

RAREA  =  RLAST* AREA 


COMPUTE  UNLOADING  QUADRATIC  COEFFICIENTS  SUCH  THAT 
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ENDPOINT  DERIVATES  ARE  NON-NEGATIVE. 


A1  =  2 . O/DX* (3 . 0«RAREA/DX-Y2) 
IF  (Al.LT.O.O)  A1  =  0.0 
A2  =  (Y2/DX-AD/DX 
IF  (A2.GE.0.0)  GO  TO  32 
A1  =  Y2/DX 
A2  =  0.0 


RESTORE  TAB  VALUES  THAT  MAY  HAVE  BEEN  CHANGED 


32  TAB (L+2) 
TAB (L+3) 
TAB(LM) 
TAB (L+5) 
TAB (L+6) 
TAB (L+7) 
TAB (LQ) 


AREA 

BLAST 

GLAST 

DG 

DCUBIC 
DREF 
=  AO 


TAB(LQ+1)  =  A1 


TAB (LQ+2 )  =  1 

98  TAB (L+ 1 )  =  D 
IF  (D.GT.DGO 

99  RETURN 
END 


DLAST.LE.DGO)  M- 
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SUBROUTINE  VEHPOS  VEHPOS 

REV  IV  07/23/86TW0PI 

COMPUTES  COMPONENTS  OF  VEHICLE  ACCELERATIONS  ONLY  AS  A  FUNCTION  VEHPOS 
OF  TIME  USING  DATA  AND  TABLES  PRODUCED  BY  SUBROUTINE  VINPUT.  VEHPOS 

VEHPOS 

IMPLICIT  REAL *8  (A-H.O-Z)  VEHPOS 

COMMON/CONTRL/  TIME, NSEG , NJNT , NPL , NBLT , NBAG , NVEH , NGRND ,  VEHPOS 

*  NS , NO , NSD , NFLX , NHRNSS , NWI NDF , N JNTF , NPRT ( 36 ) , NPG  PAGE 

COMMON/ SGMNTS/  D(3,3,30) ,WMEG(3,30) ,WMEGD(3,30) ,U1(3,30) ,U2(3,30) .VEHPOS 

*  SEGLP(3,30) ,SEGLV(3,30) ,SEGLA(3,30) ,NSYM(30)  VEHPOS 

COMMON/VPOSTN/  ZPLT (3) .SPLT (3) , AXV(3 , 6) , VATAB (6 , 501 , 6) .  VEHICL 

*  VT0(6) ,VDT(6) ,TIMEV(6) ,0MEGV(6) ,NVTAB(6) ,INDXV(6)  VEHPOS 

COMMON/ CNSNTS/  PI .RADIAN, G.THIRD.EPS (24) ,  VEHPOS 

*  UNITL .UNITM.UNITT ,GRAVTY(3) .TWOPI  TWOPI 

DIMENSION  AX (3)  VEHPOS 

T  =  TIME  VEHPOS 

M  =  1  VEHPOS 

15  DO  16  1=1,3  VEHPOS 

16  AX ( I )  =  AXV(I.M)  VEHPOS 

ATO  =  VTO(M)  VEHPOS 

ADT  =  VDT(M)  VEHPOS 

VTIME  =  TIMEV(M)  VEHPOS 

OMEG  =  OMEGV(M)  VEHPOS 

NATAB  =  NVTAB(M)  VEHPOS 

K  =  INDXV(M)  VEHPOS 

IF (NATAB. NE.O)  GO  TO  20  VEHPOS 

VEHPOS 

HALF- SINE  WAVE  DECELERATION  VEHPOS 

VEHPOS 

IF (T.GT. VTIME)  T=VTIME  VEHPOS 

WT  =  OMEG*T  VEHPOS 

SWT  =  DSIN(WT)  VEHPOS 

DO  10  1=1,3  VEHPOS 

AW  =  AX(I) »OMEG  VEHPOS 

SEGLA(I.K)  =  -AW«OMEG»SWT  VEHPOS 

10  WMEGD ( I , K)  =0.0  VEHPOS 

GO  TO  99  VEHPOS 

20  IF  (NATAB. LT.O)  GO  TO  30  VEHPOS 

VEHPOS 

UNIDIRECTIONAL  DECELERATION  VEHPOS 

VEHPOS 

IF  (T.LT. VTIME)  GO  TO  21  VEHPOS 

VEHPOS 

TIME  POINT  EXCEEDS  TABLE,  USE  LAST  VALUES  OF  ACCELERATION.  VEHPOS 

VEHPOS 

ACO  =  VATAB (1 , NATAB, M)  VEHPOS 

GO  TO  25  VEHPOS 

VEHPOS 

USE  QUADRATIC  INTERPOLATION  FROM  TABLES  FOR  CURRENT  VALUE  OF  VEHPOS 
TIME  TO  BE  CONSISTENT  WITH  SIMPSON  INTEGRATION  OF  TABLES.  VEHPOS 


c 

VEHPOS 

21 

J  =  0.5* (T-ATO) /ADT  *1.0 

VEHPOS 

XK  =  T/ADT  -DFL0AT(2*J-1) 

VEHPOS 

XI  =  XK+1.0 

VEHPOS 

X3  =  XK-1.0 

VEHPOS 

ACO  =  0 . 5*XK*X3*VATAB ( 1 , 2*J- 1 ,M) 

VEHPOS 

»  -  X3*X1*VATAB ( 1 , 2*J  ,M) 

VEHPOS 

' 

*  +  0 . 5*XK*X1*VATAB ( 1 , 2*J* 1 ,  M) 

VEHPOS 

c 

VEHPOS 

c 

COMPONENTS  OF  VEHICLE  ACCELERATION. 

VEHPOS 

c 

VEHPOS 

25 

DO  29  1=1,3 

VEHPOS 

SEGLAII.X)  =  -G*AX ( I ) *ACO 

VEHPOS 

29 

WMEGD(I.K)  =  0.0 

VEHPOS 

GO  TO  99 

VEHPOS 

c 

VEHPOS 

c 

OMNIDIRECTIONAL  DECELERATION 

VEHPOS 

c 

VEHPOS 

30 

J  =  (TIME-ATO) /ADT  +  1.0 

VEHPOS 

IF  (J.GE.-NATAB)  GO  TO  32 

VEHPOS 

c 

VEHPOS 

c 

INTERPOLATION  FROM  VINPUT  TABLES  OF  COMPONENTS  OF  VEHICLE 

VEHPOS 

c 

LINEAR  AND  ANGULAR  ACCELERATION. 

VEHPOS 

c 

VEHPOS 

TJ  =  ATO  ♦  DFLOAT ( J- 1 ) *ADT 

VEHPOS 

DLT  =  TIME-TJ 

VEHPOS 

R1  =  DLT/ADT 

VEHPOS 

R2  =  1.0-R1 

VEHPOS 

DO  31  1=1,3 

VEHPOS 

SEGLA(I.K)  =  -G* (VATAB ( I  ,J+1,M)*R1  ♦  VATAB ( I  ,J,M)»R2) 

VEHPOS 

31 

WMEGD ( I ,K)  =  RADIAN* (VATAB (I +3 , J*1 , M) *R1  ♦  VATAB (1*3 ,J ,M) «R2) 

VEHPOS 

GO  TO  99 

VEHPOS 

c 

VEHPOS 

c 

TIME  POINT  EXCEEDS  TABLE,  USE  LAST  VALUES  OF  ACCELERATION. 

VEHPOS 

c 

VEHPOS 

32 

J  =  -  NATAB 

VEHPOS 

DO  33  1=1,3 

VEHPOS 

SEGLA(I.K)  =  -G*VATAE (I  ,J,M) 

VEHPOS 

33 

WMEGD(I.K)  =  RADI  AN* VATAB ( 1  +  3 , J ,M) 

VEHPOS 

99 

M  =  M+l 

VEHPOS 

IF  (M.LE.6  .AND.  INDXV(M) .NE.O)  GOTO  15 

VEHPOS 

RETURN 

VEHPOS 

END 

VEHPOS 

SUBROUTINE  VINPUT  VINPUT 

REV  IV  07/24/86SLIP 

PERFORMS  CARD  INPUT  AND  COMPUTES  DATA  AND  TABLES  REQUIRED  BY  VINPUT 

SUBROUTINE  VEHPOS  TO  INTEGRATE  THE  CRASH  VEHICLE  MOTION  FOR  ONE  OFVINPUT 
THREE  PERMISSABLE  OPTIONS:  VINPUT 

(1)  HALF  SINE-WAVE  LINEAR  DECELERATION  IMPULSE  VINPUT 

(2)  UNIDIRECTIONAL  LINEAR  DECELERATION  TABULAR  INPUT  VINPUT 

(3)  OMNIDIRECTIONAL  LINEAR  AND  ANGULAR  ACCELERATION  TABULAR  VINPUT 

INPUT  (6  DEGREES  OF  FREEDOM  VEHICLE  MOTION)  VINPUT 

VINPUT 

IMPLICIT  REAL*8  (A-H.O-Z)  VINPUT 

COMMON/CONTRL/  TIME , NSEG , NJNT ,NPL ,NBLT ,NBAG,NVEH,NGRND,  VINPUT 

»  NS , NQ , NSD , NFLX , NHRNSS , NWI NDF , NJNTF , NPRT ( 36 ) , NPG  PAGE 

COMMON /SGMNTS/  D(3,3,30) ,WMEG(3,30) ,WMEGD(3,30) ,U1(3,30) ,U2(3.30)  .VINPUT 

*  SEGLP(3,30) ,SEGLV(3,30) ,SEGLA(3,30) ,NSYM(30)  VINPUT 

COMMON/DESCRP/  PHI (3,30) ,W(30) ,RW(30) ,SR(4.60) ,HA(3.60) ,HB(3,60)  .  SLIP 

*  RPHI (3,30) ,HT (3 , 3 ,60) .SPRING (5 ,90) , VI SC (7 ,90) ,  VINPUT 

»  JNT (30) ,IPIN(30) , I  SING (30) , I GLOB (30) , JOINTF (30)  VINPUT 

COMMON/ VPOSTN/  ZPLT (3) . SPLT (3) , AXV (3 , 6) , VATAB (6 , 50 1 , 6) .  VEHICL 

*  VT0(6) ,VDT(6) ,TIMEV(6) ,0MEGV(6) ,NVTAB(6) ,INDXV(6)  VINPUT 

COMMON /TEMP VS/  XO (3) ,XDOTO (3) .XCOMP (3) .XVCOMP (3) . ANGLE (3) ,  VINPUT 

»  ATAB(15,501) ,DVEH(3,3) ,VMEG(3) ,VMEGD(3) ,  VEHICL 

*  XACOMP (3) , THET ( 3 ) ,AX(3) ,F(5,101) ,XYZ(103,6) ,TT(103) .CHGIII 

*  VIPS.VMPH.ATO, ADT , VT I ME , OMEG , NATAB  VINPUT 

»  , SP (5 , 101 ,4) ,Q1 ( 101 ,4) , Ai (3) ,W1 (4) , QD(4) , QC (4)  JTF984 

COMMON/ INTEST/  SGTEST (3 . 4 , 30) .XTEST (3 , 120) ,SEGT(120) ,REGT(120)  VINPUT 
REAL  SEGT  VINPUT 

COMMON/CNSNTS/  PI .RADIAN, G, THIRD, EPS(24) ,  VINPUT 

*  UNI TL , UN I TM , UNI TT , GRAVTY ( 3 ) , T WOP I  TWOPI 

COMMON/TITLES/  DATE(3) ,COMENT(40) ,VPSTTL(20) ,BDYTTL(5) ,  VINPUT 

*  BLTTTL(5,8) ,PLTTL(5,30) ,BAGTTL(5,6) ,SEG(30) ,  VINPUT 

*  J0INT(30) ,CGS(30) ,JS(30)  VINPUT 

REAL  DATE , COMENT , VPSTTL , BDYTTL , BLTTTL , PLTTL , BAGTTL , SEG , JOINT  VINPUT 

LOGICAL* 1  CGS.JS  VINPUT 

DIMENSION  IDYPR(3)  VINPUT 

REAL  VEH(6) .GRND  VINPUT 

DATA  VEH/4HVEH1 , 4HVEH2 , 4HVEH3 , 4HVEH4 , 4HVEH5 , 4HVEH  / .GRND/4HGRND/  VINPUT 
DATA  IDYPR/3 ,2,1/  VINPUT 

DATA  MXTAB2/99/ .MXTAB3/501/ .MXTAB4/101/  MISC 

VINPUT 

READ  AND  PRINT  CONTENTS  OF  CARDS  C.l  AND  C.2  VINPUT 

VINPUT 

NVEH  =  NSEG  VINPUT 

NVH  =  0  VINPUT 

DO  II  1=1.6  VINPUT 

11  INDXV(I)  =  0  VINPUT 

12  READ  (5,13)  VPSTTL  VINPUT 

13  FORMAT  ( 20A4 )  VINPUT 

READ ( 5 , 14 )  ANGLE , V I PS , VT I ME , XO , NATAB , ATO , ADT , MSEG  VINPUT 

14  FORMAT (8F6 . 0 , 16 , 2F6 . 0 , 16)  VINPUT 


INTAB  =  IABS (NATAB)  CHGIII 

IF  ( NAT AB . GT . 0 . AND . I NTAB . GT . MXTAB2 )  STOP  79  MISC 

WRITE  (6,15)  NPG.VPSTTL, ANGLE, VIPS ,VT I ME, XO, NATAB, ATO, ADT, MSEG  PAGE 

NPG  =  NPG+1  PAGE 

15  FORMAT (’1  VEHICLE  DECELERATION  INPUTS’ ,94X, ’PAGE ’.I 5/1 20X,  PAGE 

*  ’CARDS  C’/3X,20A4//  PAGE 

»  7X, ’YAW’ ,9X, ’PITCH’ ,7X, ’ROLL’ ,8X, ’VIPS’ ,8X, ’VTIME’ ,7X, 'XO(X) ' .VINPUT 

*  7X, ’XO(Y) ’ ,7X, ’XO(Z) ’ , 2X, ’NATAB’ ,6X, ’ATO’ ,9X, ’ADT’ ,4X, ’MSEG’ /  VINPUT 

*  8F12.3,I5,2X,2F12.6,I5)  VINPUT 

DAI  =  ANGLE(l) *RADIAN  VINPUT 

DA2  =  ANGLE ( 2 ) *  RAD I AN  VINPUT 

AX (3)  =  DCOS (DA2)  VINPUT 

AX  II)  =  DCOS (DAI) »AX(3)  VINPUT 

AX (2)  =  DSIN(DAl) *AX(3)  VINPUT 

AX (3)  =  DSIN(DA2)  VINPUT 

IF(NATAB.NE.O)  GO  TO  18  VINPUT 

VINPUT 

HALF-SINE  WAVE  DECELERATION  VINPUT 

VINPUT 

OMEG  =  PI/VTIME  VINPUT 

AT  =  0 . 5*VIPS/OMEG  VINPUT 

IF  (VIPS. LT. O.O)  VIPS  =  0.0  VINPUT 

DO  16  1=1,3  VINPUT 

XACOMP(I)  =0.0  VINPUT 

XDOTO(I)  =  VIPS*AX(I)  VINPUT 

16  AX( I )  =  AT«AX(I)  VINPUT 

WRITE  (6,17)  VIPS. UNITL.UNITT, ANGLE, VTIME, UNITT  VINPUT 

17  FORMAT  CO  PASSENGER  COMPARTMENT  DISPLACEMENT  HISTORY’/  VINPUT 

»  ’  ANALYTICAL  HALF-SINE  WAVE  DECELERATION’/  VINPUT 

*  '  V0=’, F8. 3, IX. A4,’/’,A4,',  OBLIQUE  ANGLES  =’,3F7. 2.  VINPUT 

»  ’  DEGREES,  TIME  DURATION  = ’ ,F7.3, 1X.A4//)  VINPUT 

GO  TO  28  VINPUT 

18  IF  (NATAB. LT.O)  GO  TO  31  VINPUT 

VINPUT 

FOR  UN  .ECTIONAL  VEHICLE  MOTION  VINPUT 

READ  Li  AR  DECELERATION  TABLES  FROM  CARDS  C.3  VINPUT 

VINPUT 

READ  (5,19)  (ATABU  ,1)  ,1  =  1  .NATAB)  VINPUT 

19  FORMAT  (12F6.0)  VINPUT 

VINPUT 

EXTEND  TABLE  IF  NECESSARY  SUCH  THAT  NATAB  IS  ODD  AND  VINPUT 

LAST  ENTRY  NEED  NOT  BE  ZERO.  IF  TABLE  SIZE  IS  EXCEEDED  ON  TIME,  VINPUT 
VALUE  OF  LAST  ENTRY  WILL  BE  USED.  VINPUT 

VINPUT 

IF  (MOD (NATAB, 2) .EQ. 1)  GO  TO  20  VINPUT 

ATAB(1 .NATAB+1)  =  AT AB ( 1 . NATAB )  VINPUT 

NATAB  *  NATAB +1  VINPUT 

20  VTIME  =  ADT  *  DFLOAT (NATAB- 1)  VINPUT 

VINPUT 

USING  SIMPSON’S  INTEGRATION,  COMPUTE  VELOCITY  AND  DISPLACEMENT  VINPUT 
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TABLE  FOB  NATAB  EQUALLY  SPACED  (ADT)  TIME  POINTS. 
FOB  1=1, NATAB 

ATAB (1,1)  =  LINEAB  DECELERATION  (G’S) 

ATAB (2,1)  =  LINEAB  VELOCITY  (L  UNITS/T  UNITS) 
ATAB (3,1)  =  LINEAR  DISPLACEMENT  (L  UNITS) 

ATAB (2,1)  =  VIPS 

ATAB (3,1)  =  0.0 

DAI  =  ADT/3.0 

DA2  =  ADT/ 12.0 

UNITS  =  -G 

DO  22  J=2 . 3 

DO  21  1=2, NATAB, 2 

FI  =  ATAB (J- 1,1-1)  »  UNITS 

F2  =  ATAB (J- 1,1  )  *  UNITS 

F3  =  ATAB(J-1 ,1+1)  *  UNITS 

ATAB ( J , I  )  =  ATAB ( J , I- 1)  +  DA2* (5 . 0*Fl+8 . 0»F2-F3) 

21  ATAB ( J , 1+ 1)  =  ATAB ( J , I - 1 )  +  DA1*(  Fl+4 . 0*F2+F3) 

22  UNITS  =  1.0 


PRINT  TABLES 

WRITE  (6,23)  (UNITL,UNITT,UNITL,I=1 ,2) 

23  FORMAT ( ' 0  UNIDIRECTIONAL  VEHICLE  POSITION  TABLES’// 

*  2 ( '  TIME  ACC  VELOCITY  POSITION 

*  2 ( ’  (MSEC)  (G)  ( ’ , A4 , ’ / * , A4 , ’ ) ’ , 5X , ’ ( ’ , A4 , 

DO  26  J=1 , 50 

IF  (J.GT. NATAB)  GO  TO  26 
T1  =  (ATO  +  DFL0AT(J-1)*ADT)* 1000.0 
IF  (J+50.LE. NATAB)  GO  TO  25 
WRITE  (6,24)  Tl, (ATAB(I,J) ,1=1,3) 

24  FORMAT (2 (FI 1.5,F10.2,F13.4,F13.5, 3X) ) 

GO  TO  26 

25  T2  =  (ATO  +  DFLOAT (J+49) *ADT) »1000. 0 

WRITE  (6,24)  Tl, (ATAB(I.J) ,1=1,3) ,T2, (ATAB (I , J+50) ,1=1,3) 

26  CONTINUE 

INITIALIZATION 
DO  27  1=1,3 

XACOMP ( I )  =  ~G*AX ( I ) »ATAB (1,1) 

27  XDOTO ( I ) =  VIPS*AX(I) 

28  DO  30  1=1,3 
DO  29  J=1 ,3 

29  DVEH(I,J)  =  0.0 
DVEH(I.I)  =  1.0 
VMEGD(I)  =0.0 

30  VMEG(I)  =  0.0 
GO  TO  64 
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FOR  OMNIDIRECTIONAL  (6  DEGREES  OF  FREEDOM)  VEHICLE  MOTION  VINPUT 

READ  LINEAR  DECELERATION  AND  ANGULAR  ACCELERATION  TABLES  VINPUT 

FROM  CARDS  C.2.B  AND  C.4.  CHGIII 

VINPUT 

31  MATAB  =  -NATAB  VINPUT 

READ  (5,32)  LTYPE ,LFIT ,NPTS , (VMEG(I) ,1=1,3)  VINPUT 

32  FORMAT  (316 , 22X , 3F10 . 0)  VINPUT 

IF  (MATAB. GT.MXTAB3)  STOP  80  MI SC 

IF  ( LTYPE. EQ. 2. AND. LFIT. LT. 1)  STOP  82  CHGIII 

IF  (LTYPE. EQ. 1 . AND.LFIT.LT.2)  STOP  83  VEHICL 

IF  (LTYPE. GT.O)  GO  TO  34  VINPUT 

READ  (5,33)  ( (ATAB (I , J) , 1=1 . 3) , (ATAB (I , J) , 1= 10 , 12) , J=1 .MATAB)  VINPUT 

33  FORMAT  (10X.6F10.0)  VINPUT 

ISKIP  =  0  VINPUT 

GO  TO  46  VINPUT 

CHGIII 

FOR  SPLINE  FIT  VEHICLE  MOTION  CHGIII 

READ  DATA  FROM  CARDS  C.5.  CHGIII 

CHGIII 

34  LPTS  =  LTYPE- 1  +  NPTS  VINPUT 

IF  ( NPTS . GT . MXTAB3 )  STOP  84  MI SC 

READ  (5,35)  (TT(I) , (XYZ(I , J) ,J=1 ,6) ,1=1 ,LPTS)  VINPUT 

35  FORMAT  (7F10.0)  VINPUT 

WRITE  (6,36)  LTYPE , LFIT , NPTS  CHGIII 

36  FORMAT  CO  SPLINE  FIT  TABULAR  INPUT’//  CHGIII 

«  3X, 'LTYPE  *',18,’  LFIT  = ’ ,16, ’  NPTS=’,I6/)  CHGIII 

IF  (LTYPE. EQ. 2)  WRITE(6,701)  UNITL, UNITT ,TT( 1) , (XYZ ( 1 , J) , J=1 ,6)  CHGIII 
IF  (LTYPE. EQ. 3)  WRITE(6,702)  UNITL, UNITT, TT(1) , (XYZ(1 ,J) ,J=1 ,6) ,  CHGIII 
»  UNITL. UNITT. UNITT, UNITT, TT(2) , (XYZ(2,J) ,J=1, 6)  CHGIII 

701  FORMAT (32X  , ' INITIAL  LINEAR  POSITION  (’ ,A4 ,’) ’,17X, ’ INITIAL  ANGULACHGI I I 

»R  POSITION  (DEG) ’ ,/,3X, ’TIMEC , A4 , ’ ) = ’ ,F9 . 4 ,3X, 2 ( ’ X= ’ ,F10 . 3 , 2X ,  JTF984 

«  ’ Y= ' ,F10 . 3 , 2X, ’ Z= ’ ,F10 . 3 ,8X) , /)  CHGIII 

702  FORMAT (32X,  ’INITIAL  LINEAR  POSITION  (’ ,A4 ,’)’, 17X, ’ INITIAL  ANGULACHGI I I 

»R  POSITION  (DEG) ’ , / , 3X, 'TIME ( ' , A4 , ’ ) = ’ ,F9 . 4 ,3X,2 ( ’ X= ’ ,F10. 3 ,2X,  JTF984 

«  ’Y=’ .F10.3.2X, *Z=’ .F10.3.8X) ,/,30X,  ’INITIAL  LINEAR  VELOCITY  (’.CHGIII 

•  A4.’/’,A4,’),,12X,’ INITIAL  ANGULAR  VELOCITY  (DEG/ ’ . A4 . ’ ) ’ ,  CHGIII 

»/,3X, 'TIME ( ’ , A4 , ’ ) = ’ ,F9. 4 ,3X,2 ( ’X= ’ ,F10. 2 , 2X, ’Y=’ ,  CHGIII 

»  F10.2.2X, ’Z=’ .F10.2.8X) ,/)  CHGIII 

IF  (LTYPE. EQ.l)  WRITE (6, 703)  UNITL, UNITT  CHGIII 

IF  (LTYPE. EQ. 2)  WRITE(6,704)  UNITL, UNITT, UNITT, UNITT  CHGIII 

IF  (LTYPE. EQ. 3)  WRITE(6,705)  UNITT. UNITT  VEHICL 

703  FORMAT (29X  . 'LINEAR  POSITION  (' ,A4, ’)’ ,21X, 'ANGULAR  POSITION  (DECHGIII 

«G) ’ .  / ,5X, 'TIME ( ' ,A4 , ’ ) ' , 11X, ’X’ , 11X, ’ Y’ , 11X, ’Z’ , 18X, ’YAW’ ,8X,  VEHICL 
•’PITCH' ,8X, 'ROLL' )  VEHICL 

704  FORMAT (26X, 'LINEAR  VELOCITY  ( ’ , A4 , ’ / ’ , A4 , ’ ) ’ , 16X,  CHGIII 

•  'ANGULAR  VELOCITY  (DEG/ ’ ,A4 ,’)’,/, 5X , ’TIME (’ ,A4 ,’)’ ,  CHGIII 

•  1 1 X , 2 ( ' X ’ , 1 IX, ' Y’ , 1 1 X , ’Z’ , 19X) )  CHGIII 

705  FORMAT  (26X, 'LINEAR  DECELERATION  (G”S)’,15X,  VEHICL 

•  'ANGULAR  ACCELER/T I ON  (DEG/ ’ ,A4 ,’ *«2) ’,/, 5X, 'TIME (', A4 ,’)’ ,  CHGIII 

•  11X,2('X’,11X,’T',11X,’Z’, 19X) )  CHGIII 


IF  (LTYPE.EQ. 1)  WRITE(6,706)  (TT(I) . (XYZ(I ,J) ,J=1 .6) ,1=1 .LPTS)  CHGIII 

IF  (LTYPE.EQ. 2)  WRITE(6,706)  (TT(I) , (XYZ(I , J) . J=1 ,6) . 1=2 ,LPTS)  CHGIII 

IF  (LTYPE.EQ. 3)  WRITE(6,706)  (TT(I) , (XYZ(I ,J) ,J=1 ,6) ,1=3, LPTS)  CHGIII 

706  FORMAT (1X,F12.5,6X,3F12.3,8X,3F12.3)  CHGIII 

DO  37  1=1,3  VINPUT 

XO (I)  =  XYZ(l.I)  VINPUT 

XDOTO(I)  =  XYZ (2,1)  VINPUT 

VMEG(I)  =  XYZ(2 , 1+3)  VINPUT 

37  ANGLE (I)  =  XYZ (1,1 +3)  JTF984 

IMJ  =  6  JTF984 

IF (LTYPE.EQ. 1) IMJ  =  3  JTF984 

DO  45  I 1=1, IMJ  JTF984 

CALL  SPLINE  (TT(LTYPE) , XYZ (LTYPE , II) ,F ,NPTS ,LFIT)  VINPUT 

I  =  II  VINPUT 

IF  (II.GT.3)  I  =  II  +  6  VINPUT 

IF (LTYPE.EQ. 1)  XDOTO(I)  =  F (3 . 1)  JTF984 

UNITS  =1.0  JTF984 

IF  (LTYPE.LT. 3  .AND.  II.LE.3)  UNITS  =  -1.0/G  VINPUT 

K1  =  1  VINPUT 

DO  45  J  = 1 , MATAB  VINPUT 

TTT  =  ATO  +  DFLOAT ( J- 1 ) #ADT  VINPUT 

DO  39  L=K1 ,NPTS  JTF984 

K  =  L  JTF984 

IF  (TTT.LT.F(1 ,L+1) )  GO  TO  40  VINPUT 

39  CONTINUE  VINPUT 

40  K1  =  K  VINPUT 

DX  =  TTT  -  F( 1 ,K)  VINPUT 

IF  (LTYPE- 2)  41,42,43  BUTLER1 

41  ACC  =  2 . 0»F (4 ,K)  +  6.0«DX«F(5,K)  VINPUT 

GO  TO  44  VINPUT 

42  ACC  =  F(3,K)  +  DX» (2 . 0*F (4 ,K) +3 . 0»DX*F (5 ,K) )  VINPUT 

GO  TO  44  VINPUT 

43  ACC  =  F (2 ,K)  +  DX* (F (3 , K) +DX* (F(4 ,K) +DX»F (5 ,K) ) )  VINPUT 

44  ATAB(I,J)  =  ACC»UNITS  VINPUT 

45  CONTINUE  VINPUT 

ISKIP  =  1  VINPUT 

IF (LTYPE. NE. 1 )G0  TO  46  JTF984 

C  CODE  FOR  OMEGA  ROUTINE:  COMPUTE  ATAB (I , J) , 1= 10 , 1 1 , 12  J  =  1, MATAB  JTF984 
DO  80  I  =  l.NPTS  JTF984 

DO  91  K  =  1,3  JTF9S4 

91  A1(K)  =  XYZ(I,K+3)  JTF984 

CALL  QUAT(Al.Wl)  JTF984 

DO  76  K  =  1,4  JTF984 

76  Ql(I.K)  =  W1(K)  JTF984 

I F ( I . EQ . 1 ) GO  TO  80  JTF984 

TA  =  0.0  JTF984 

TB  =  0.0  JTF984 

DO  77  K  =  1.4  JTF984 

TA  =  TA  +  DABS (Q 1 (I , K)  -  Ql(I-l.K))  JTF984 

77  TB  =  TB  +  DABS(Q1(I,K)  +  Ql(I-l.K))  JTF984 


IF (TA. LE .TB) GO  TO  80 
DO  78  K  =  1.4 
78  Ql(I.K)  =  -Ql(I.K) 

80  CONTINUE 

DO  82  K  =  1.4 

82  CALL  SPLINE (TT.Ql ( 1 ,K) ,SP ( 1 , 1 ,K) .NPTS.LFIT) 

DO  90  J  =  l.MATAB 

TTT  =  ATO  +  DFLOAT(J-l) *ADT 
K1  =  I 

DO  83  L  =  Kl.NPTS 
K  =  L 

83  IF1TTT.LT. SP(I,L+1.1))G0  TO  84 

84  K1  =  K 

DX  =  TTT  -  SP(l.K.l) 

DO  85  L  =  1.4 

Wl(L)  =  SP (2  ,K ,L)  +DX*  (SP (3  ,K ,L)  +DX*  (SP (4  ,K  ,L)  +DX*SP (5 , K , L) ) ) 
QD(L)  =  2 . 0*SP (4 ,K ,L)  +  6 . 0*DX»SP (5 ,K ,L) 

85  IF1J.EQ. l)QC(L)  =  SP (3 ,K,L) +DX* (2 . 0*SP (4 ,K ,L) *DX*3 . 0*SP (5 ,K ,L) ) 
CCC  =  2.0/RADIAN 

IF1J.GT.  DGO  TO  88 
CALL  CR0SS(QC(2) , W1 (2) ,A1) 

DO  86  K  =  1.3 

86  VMEG(K)  =  CCC* (W1 ( 1) *QC (K* 1)  -  QC(1>*W1(K+1)  ♦  Al(K)) 

CALL  DRCQUA(DVEH.Wl) 

CALL  YPRDEG1DVEH, ANGLE) 

88  CALL  CR0SS1QD12) ,W1(2) . QC ( 2 ) ) 

DO  89  K  =  2.4 

89  ATABOO-8,  J)  =  CCC*  (W1  ( 1 )  *QD(K)  -QD(  1)  »W1  (K)  ♦  QC(K)> 

90  CONTINUE 

46  DO  55  J= l.MATAB 

IF  (M0D1J.45) .NE. 1)  GO  TO  49 

PRINT  PAGE  HEADING  AT  START  OF  EACH  45  TIME  POINTS. 

IPAGE  =  (J-D/45  +  1 
IF  (ISKIP.EQ.l)  WRITE  (6,75)  NPG 
IF  (ISKIP.EQ.l)  NPG=NPG+ 1 
75  FORMAT!’ 1’ ,122X.’ PAGE’ .15) 

WRITE  (6,48)  YPSTTL , IPAGE , UNITL, UNITT , UNITL 

48  FORMAT (’0  VEHICLE  LINEAR  TIME  HISTORY’ .3X.20A4.3X. 

»  ’PAGE  NO. ’ .13// 

*  4X,  ’TIME’  ,12X,  ’LINEAR  DECELERATIONS  (G”S)  '  . 

*  1 IX, ’LINEAR  VELOCITIES  ( ’ , A4 , ’ / ’ , A4 . ’ ) ’ , 

*  1 IX, 'LINEAR  DISPLACEMENTS  ( ’ , A4 , ’ ) '  / 

*  3X, ’ (MSEC) ’ , 3 ( 1 IX, ' X’ .llX.’Y’.llX.’Z’ ,3X)  /  ) 

ISKIP  =  1 

49  IF  (J.GT. 1)  GO  TO  52 

INTEGRATION  INITIALIZATION  FOR  TIME  =  0. 
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DO  50  1=1,3  VINPUT 

ATAB(I+6,J)  =  X0(I)  VINPUT 

50  ATAB ( I  + 1 2 ,  J )  =  VMEG(I)  JTF984 

CALL  DRCYPB  (DVEH, ANGLE , IDYPR)  VINPUT 

DO  51  1=1,3  VINPUT 

IF  (LTYPE.EQ.O)  XDOTO(I)  =  VIPS*DVEH( 1 . I)  VINPUT 

51  ATAB(I+3,J)  =  XDOTO(I)  VINPUT 

GO  TO  54  VINPUT 

52  DO  53  1=1,3  VINPUT 

VINPUT 

INTEGRATE  LINEAR  VELOCITY  AND  DISPLACEMENT.  VINPUT 

VINPUT 

ATAB ( 1+3 , J)  =  ATAB (1+3 , J-l) -G»ADT/2 . 0» (ATAB (I , J— 1 ) +ATAB ( I , J) )  VINPUT 

53  ATAB (I +6 ,J)  =  ATAB (I +6 , J-l)  VINPUT 

»  +ADT* (ATAB (I +3 ,J- 1) -G&ADT/6 . 0* (2 . 0* ATAB (I , J-l) + ATAB (I , J) ) )  VINPUT 

54  T1  =  (ATO  ♦  DFLOAT(J-l)*ADT)* 1000.0  VINPUT 

55  WRITE (6, 56)  T1 , (ATAB(I . J) , 1=1 ,9)  VINPUT 

56  FORMAT (F9 . 3 , 3 (3X , 3F12 . 3) )  VINPUT 

DO  61  J  = 1 , MATAB  VINPUT 

IF  (MOD ( J , 45) . NE . 1 )  GO  TO  58  VINPUT 

VINPUT 

PRINT  PAGE  HEADING  AT  START  OF  EACH  45  TIME  POINTS.  VINPUT 

VINPUT 

IPAGE  =  (J-l)/45  ♦  1  VINPUT 

WRITE  (6,57)  VPSTTL.NPG, IPAGE, UNITT.UNITT  PAGE 

NPG=NPG+ 1  PAGE 

57  FORMAT ( ’ 1  VEHICLE  ANGULAR  TIME  HISTORY’, 3X, 20A4 , 10X, ’ PAGE’, 15/  PAGE 

*  116X,’PAGE  NO. ’,13/  PAGE 

»  4X, ’TIME’ ,  7X, 'ANGULAR  ACCELERATIONS  (DEG/’ ,A4, ’ **2) ’ ,  VINPUT 

*  7X, ’ANGULAR  VELOCITIES  (DEG/’ ,A4.’) ’ ,  VINPUT 

»  1 IX, 'ANGULAR  DISPLACEMENTS  (DEG)’  /  VINPUT 

*  3X, ’ (MSEC) ' . 2 ( 1 IX, ’X’ ,11X, ’Y’ ,11X, ’Z’ ,3X) ,  VINPUT 

*  10X, ’YAW’ ,8X, ’PITCH’ ,8X, ’ROLL’  /)  VINPUT 

58  IF(J.EQ.l)  GO  TO  60  VINPUT 

VINPUT 

INTEGRATE  ANGULAR  VELOCITY  AND  DISPLACEMENT.  VINPUT 

VINPUT 

DO  59  1=1,3  VINPUT 

ATAB (1+ 12 , J)  =  ATAB ( 1+ 12 , J- 1 ) + (ATAB (1+9 , J-l) ♦ ATAB (1+9 ,J) ) »ADT/2 . 0  VINPUT 

59  THET(I)  =  ADT* (ATAB (1+ 12 ,J- 1) ♦ (2 . 0*ATAB ( 1+9 , J-l) ♦ ATAB (1+9, J) ) *ADT  VINPUT 

*/6 . 0) * RADIAN  VINPUT 

CALL  DSETD ( DVEH , THET , THT )  VINPUT 

60  CALL  YPRDEG( DVEH, THET)  VINPUT 

T1  =  (ATO  +  DFL0AT(J-1)«ADT)» 1000.0  VINPUT 

61  WRITE  (6,56)  T1 , ( ATAB ( I , J) , 1= 10 , 15) ,THET  VINPUT 

VINPUT 

PROGRAM  INITIALIZATION  FOR  TIME  =  0.  VINPUT 

VINPUT 

CALL  DRCYPR  (DVEH, ANGLE , IDYPR)  VINPUT 

DO  63  1=1,3  VINPUT 
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XACOMP(I)  =  -G»ATAB (1,1) 

VMEG(I)  =  ATAB (1+12,1) » RADI AN 

63  VMEGD(I)  =  ATAB (I +9  , 1)»BADIAN 

64  J  =  MS EG 

IF  (MSEG.EQ. 0)  GO  TO  65 
IF  (MSEG.LE.MSEG)  GO  TO  66 
IF  (MSEG.NE.HVEH+1)  STOP  6 

65  NVEH  =  NVEH+1 
J  =  MVEH 

SETUP  FOR  ALL  PRESCRIBED  SEGMENT  MOTION. 

66  NVH  =  NVH+1 
ISING(J)  =  -1 

IF  (MSEG.GT.NSEG)  SEG(J)  =  VEH(NVH) 

RW( J)  =  0.0 
DO  67  1=1,3 

RPHI  (I.J)  =  0.0 
SEGLA(I.J)  =  VMEGD(I) 

WMEGD(I.J)  =  XACOMP ( I ) 

67  AXV(I.NVH)  =  AX(I) 

VTO (NVH)  =  ATO 
VDT(NVH)  =  ADT 
OMEGV(NVH)  =  OMEG 
TIMEV(NVH)  =  VTIME 
NVTAB (NVH)  =  NATAB 
INDXV(NVH)  =  J 

NJ  =  IABS (NATAB) 

IF  (NJ.LE.O)  GO  TO  69 
DO  68  K= 1 ,NJ 
DO  68  1=1,3 

VATAB ( I  ,K,NVH)  =  ATAB(I.K) 

68  VATAB ( I +3, K, NVH)  =  ATAB(I+9,K) 

69  IF  (J.LE.NSEG)  GO  TO  72 


=  ATAB(I.K) 

=  ATAB (I +9, K) 
GO  TO  72 


SETUP  FOR  NEW  VEHICLE  (SEGMENT)  MOTION. 

W(J)  =  0.0 
RW( J)  =  0.0 
DO  71  1=1,3 

DO  70  K=1 ,3 

D(I.K.J)  =  DVEH(I.K) 

70  SGTESTd  ,K,J)  =  0.0 
SGTEST(I ,4 , J)  =  0.0 


SEGLPd  ,  J) 
SEGLVd.J) 
WMEG  (I.J) 
PHI  (I.J) 
71  RPHI  (I.J) 


X0(I) 
XDOTO ( I ) 
VMEG(I) 
0.0 
0.0 


72  IF  (MSEG.NE.O)  GO  TO  12 
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SEG(NVEH)  =  VEH(6) 

C 

SET  UP  SEGMENT  DATA  FOR  GROUND 
NGRND  =  NVEH+ 1 

IF  (NGRND. GT. 30  .OR.  NVH.GT.6)  STOP  7 
SEG (NGRND)  =  GRND 
J  =  NGRND 
ISING(J)  =  -1 
W(J)  «  0,0 
RW(J)  =  0.0 
DO  74  1=1,3 

DO  73  K=  1 , 3 

D (I , K , J)  =  0.0 

73  SGTEST (I ,K , J)  =  0.0 
D(I.I.J)  =  1.0 
SGTEST ( I , 4 , J)  =0.0 
SEGLP(I.J)  =  0.0 
SEGLV(I.J)  =  0.0 
SEGLA(I.J)  =  0.0 
WMEG  (I.J)  =  0.0 
WMEGD(I.J)  =  0.0 
PHI  (I.J)  =  0.0 

74  RPHI  (I.J)  =  0.0 
RETURN 
END 
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DOUBLE  PRECISION  FUNCTION  VISCOS (ZD , VISC ,HA)  VISCOS 

REV  19  I0/23/78VISC0S 

COMPUTES  SUM  OF  COULOMB  AND  VISCOUS  TORQUES  VISCOS  §8 

AT  JOINTS  AS  A  FUNCTION  OF  THETA  DOT.  VISCOS 

ACTUALLY  ROUTINE  RETURNS  SUM/ZD.  VISCOS  jjS 

VISCOS  ftjj 

ARGUMENTS:  VISCOS  fifi 

ZD  :  'THETA  DOT!  WHERE  THETA  IS  THE  ANGLE  OF  THE  JOINT.  VISCOS 
VISC:  ARRAY  OF  5  VALUES  DESCRIBING  FUNCTION  EVALUATION.  VISCOS  gf 

VISCOS  Of; 

IMPLICIT  REAL *8  (A-H.O-Z)  VISCOS  «■ 

DIMENSION  VISC (5)  VISCOS  j® 

Z  =  ZD  VISCOS  fiS 

IF  (ZD.LT. VISC(3) )  Z  =  VISC (3) / (2 . 0-ZD/VISC (3) )  VISCOS 


HA  =  (Z-ZD) /Z 

VISCOS  =  VISC ( 1 ) +VISC (2) /Z 

RETURN 

END 


VISCOS 

VISCOS 

VISCOS 

VISCOS 


SUBROUTINE  VISPR(IJ,NJ)  VISPR 

REV  IV  02/01/88MISD0T 

COMPUTES  VISCOS  AND  SPRING  TORQUES  AT  THE  JOINTS  VISPR 

AND  ADDS  THEM  TO  THE  U2  ARRAY.  VISPR 

VISPR 

ARGUMENTS:  VISPR 

NJ  =  0  -  REGULAR  COMPUTATION  FOR  ALL  JOINTS  VISPR 

•  0  -  COMPUTE  ONLY  FOR  JOINT  NJ  IMPULSE  VISPR 

VISPR 

IJ  =  1  IMPULSE  FOR  FLEXURE  ONLY  VISPR 

=  2  IMPULSE  FOR  TORSION  ONLY  VISPR 

=  4  IMPULSE  FOR  GLOBALGRAPHIC  ONLY  VISPR 

VISPR 

IMPLICIT  REAL* 8  (A-H.O-Z)  VISPR 

COMMON/ CONTRL/  T I ME , NSEG , N JNT , NPL , NBLT , NB AG , NVEB , NGRND ,  VISPR 

*  NS , NQ , NSD , NFLX , NHRNSS , NWINDF , NJNTF , NPRT ( 36) , NPG  PAGE 

COMMON/SGMNTS/  D(3,3,30) ,WMEG(3,30) ,WMEGD(3,30) ,U1(3.30) ,U2(3,30) .VISPR 

»  SEGLP(3,30) ,SEGLV(3,30) ,SEGLA(3,30) ,NSYM(30)  VISPR 

COMMON/DESCRP/  PHK3.30)  ,W(30)  ,RW(30)  ,SR(4,60)  ,HA(3,60)  ,HB(3,60)  ,  SLIP 

*  RPHK3.30)  ,HT(3.3,eO)  , SPRING(5 ,90)  ,VISC(7,90)  ,  VISPR 

*  JNT(30) ,IPIN(30) ,ISING(30) ,IGL0B(30) ,JOINTF(30)  VISPR 

COMMON/ CMATRX/  Vl(3,30) ,V2(3,30) ,V3(3,12) ,B12(3,3,60) ,A22(3,3,60) .VISPR 

»  F(3,30) ,TQ(3,30) , WJ(30) .All (3,3,30)  SLIP 

COMMON/FORCES/PSF (7 , 70) ,BSF(4,20) ,SSF(10,40) ,BAGSF(3,20) ,  NCFORC 

*  PRJNT(7,30) ,NPANEL(5) . NPSF . NBSF , NSSF . NBGSF  VISPR 

COMMON/CEULER/  IEULER(30) ,HIR(3,3,90) ,ANG(3,30) ,ANGD(3,30) ,  JDRIFT 

»  FE(3,30) ,TQE(3,30) ,C0NST(5,30)  JDRIFT 

COMMON/TEMPVI/  CREST .TTI (3) ,R1I (3) ,R2I (3) , JST0P(4 ,2 ,30)  VISPR 

COMMON/CNSNTS/  PI .RADIAN, G, THIRD, EPS(24) ,  VISPR 

*  UNITL.UNITM.UNITT,GRAVTY(3) .TWOPI  TWOPI 

COMMON/TEMPVS/  T3 (3) ,T6 (3) ,T7 (3) ,T8 (3) ,T9 (3) ,  VISPR 

*  WIJ(3)  , ANGLO)  ,DH1  (3,3)  ,HD3(3,3)  ,  VISPR 

*  HAD ,HBD , WI JM.CV.CSA.CSB ,TQC  VISPB 

IF  (NJNT.LE.O)  GO  TO  99  VISPR 

CALL  ELTIME ( I , 13)  VISPR 

IF  ( NPRT (12) . NE . 0 )  WRITE  (6,11)  TIME, NPG  PAGE 

IF  ( NPRT (12) . NE . 0 )  NPG=NPG+1  PAGE 

11  FORMAT  Cl  VISPR  COMPUTATIONS  FOR  TIME  = ’ ,F12 . 6 ,80X, ’ PAGE’ , 15)  PAGE 

J 1  =  1  VISPR 

J2  =  NJNT  VISPB 

IF  (NJ.EQ.O)  GO  TO  13  VISPR 

J1  *  NJ  VISPR 

J2  *  NJ  VISPR 

13  DO  90  J  =  J1  ,J2  VISPR 

DO  12  L=1 ,3  VISPB 

T3(L)  =  0.0  VISPR 

T6(L)  =  0.0  VISPB 

ANGL(L)  =  0.0  VISPR 

12  TQ(L, J)  =  0.0  VISPR 

WJ(J)  =  0.0  VISPR 


REV  IV 


c  VISPB 

C  DO  NOT  COMPUTE  TORQUES  FOR  NULL,  LOCKED  OR  EULER  JOINTS.  VISPR 

C  VISPR 

I  =  IABS ( JNT ( J) )  VISPR 

IF  (I.LE.O)  GO  TO  90  VISPR 

CALL  D0T33  (D ( 1 , 1 , J* 1) ,HT( 1 , 1 , 2»J) ,HIR( 1 , 1 , J) )  VISPR 

IF  (IABS(IPIN(J) ) . EQ. 4)  00  TO  90  SLIP 

C  VISPR 

C  ZERO  T1-T9  ARRAYS  AND  HAD,HBD,WIJM,CV,CS4,CSB  AND  TQC.  VISPR 

C  VISPR 

WIJM  =0.0  VISPR 

HAC  =  0.0  BUTLER 1 

CV  =0.0  VISPR 

CSA  =0.0  VISPR 

CSB  =0.0  VISPR 

TQC  =0.0  VISPR 

CALL  D0T33  (D (1 , 1 , 1) ,HT (1 , 1 ,2«J-1)  ,DH1)  VISPR 

CALL  DOT33  (DH1 , HIR( 1 , 1 , J) ,HD3)  VISPR 

DO  220  L= 1 ,3  TGMODti 

DO  220  K=1 ,3  TGMOD0 

IF(DABS(HD3(L,K) ) . LT.EPS(IO) )  HD3(L,K)  =  O.DO  TGM0D6 

220  CONTINUE  TGII0D6 

HAD  =  HD3 (3 , 3)  VISPR 

IF  (HAD.GT.  1.0)  HAD  =  1.0  VISPR 

IF  (HAD. LT. -1.0)  HAD  =  -1.0  VISPR 

ANGL(l)  =  DACOS (HAD)  VISPR 

IF  ( (HD3 (2 ,3) . NE.0.0  .OB.  HD3 (1 ,3) . NE. 0. 0) . AND. IABS (IPIN(J) ) .NE. 7)SLIP 
»ANGL (2)  =  DATAN2(HD3(2,3) ,HD3(1,3))  VISPR 

ANGLO)  =  DATAN2{HD3(2,1)-HD3(1,2)  ,HD3(1 , 1)  ♦HD3(2,2) )  VISPB 

IF (NPRT (12) .NE. 0. AND. IPIN(J) . LT. 0)  WRITE  (8,739)  J,I,ANGL,  TGM0D6 

»((D(L,K,J+1) , K=1 ,3) , (HT(L,K,2»J) ,K=1 ,3) , (HIR(L,K, J) ,K=1,3) ,L"1,3) , TGM0D6 
» ( (D (L,K , I ) ,K= 1 ,3) , (HT(L,K,2»J-1) ,K=1 ,3) , (DH1 (L,K) ,K=1,3) ,L»1.3) ,  TG1I0D6 
»  ( (HD3(L,K) ,K=1 ,3) ,L=1 ,3)  TGM0D6 

739  FORMAT (1H0,*J=  M2, IX, ’I*  ’  ,  12 ,3(2X,D14.7)  ,/ ,  TGM0D6 

*  2(3(9(1X,D13.6) ,/) ,/) ,3(3(2X,D18.12) ,/))  TGM0D6 

IF  (IPIN(J) .LT.O)  GO  TO  41  VISPR 

IF  (NJ.NE.O.AND. IJ.EQ.4)  GO  TO  27  VISPR 

C  VISPB 

C  CONVERT  TO  INERTIAL  REFERENCE  SYSTEM  VISPR 

C  Tl=  D(I) ’«HA(NJ)  T4=D(J*1) ’»HA(MJ)  VISPR 

C  T3=  D( I ) ' »WMEG( I )  T6=D(J*1) ' «WMEG(J+1)  VISPR 

C  VISPR 

C  HAD  =  COS  TA  =  T1.T4  VISPB 

C  WIJ  =  T3-T6  VISPR 

C  WJ  =  'WIJ!  VISPR 

C  VISPR 

DO  20  L=1 ,3  VISPB 

DO  15  M= 1 , 3  VISPB 

T3(L)  =  T3 (L) ♦  D(M,L,I)»  WMEG(M.I)  VISPB 

15  T6(L)  =  T8 (L) ♦  D(M,L.JM)»  WMEG(M,J*l)  VISPR 
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WIJ(L)=  T3 (L) -T6 (L) 

20  WIJM  =  WIJM  ♦  WIJ (L) »*2 
WIJM  =  DSQRT(WIJM) 

IF  ( WIJM.LE.EPS (12))  WIJM  =0.0 
WJ(J)  =  WIJM 

T7  =  T1  X  T4 
HAC  =  !T7! 

CALL  CROSS  (DHK1.3)  ,H1R(1,3,J)  ,T7) 

HACC  =  T7 ( 1) *»2  +  T7 (2) ««2  +  T7(3)«»2 
HAC  =  DSQRT (HACC) 

COMPUTE  CV,  THE  MAGNITUDE  OF  VISCOUS  AND  COULOMB  TORQUE/ WIJM 
RA  =  +SGN  TA  DOT  =  -WIJ.T7 
AND  CSA,  THE  MAGNITUDE  OF  FLEXURE  TORQUE/HAC 

CV  =  VISCOS (WIJM, VISC ( 1, 3*J-2) .HA2) 

IF  (NJ.EQ.O)  HA(2 , 2*J)  =  HA2 
CREST  =  VISC (7 ,3*J-2) 

RA  =  - (WIJ (1) «T7 ( 1)  ♦  WIJ (2) »T7 (2)  +  WIJ(3) *T7(3) ) 

IF  (HAC.LT.EPS (12) )  RA=0.0 
IF  (HAC.GE.EPS (12) )  RA=RA/HAC 
JSTP  =  0 

IF  (IPIN(J) .EQ.7)  GOTO  25 

IF  (JOINTF(J) .EQ.O)  CSA  =  EFUNCT ( ANGL ( 1 ) , RA, SPRING! 1 ,3»J-2) .JSTP) 
IF  (JOINTF(J) .NE.O)  CSA  =  FNTEBP ( ANGL ( 1 ) ,ANGL(2) , JOINTF(J) ) 

IF  (HAC.LT.EPS (12))  CSA=0.0 
IF  (HAC.GE.EPS (12))  CSA=CSA/HAC 
IF  (NJ.EQ.O)  JSTOP ( 1 , 1 , J)  =  JSTP 
IF  (IPIN(J) .EQ. 1)  GO  TO  34 
IF  (IPIN(J) . EQ.6)  GOTO  34 

RB  =  +SGN  TB  DOT  =  -WIJ.T8 

COMPUTE  CSB,  THE  MAGNITUDE  OF  TORSIONAL  TORQUE/HBC 

RB  =  - (WIJ(l) »HIR(1 ,3,J)  ♦  WIJ (2) »HIR(2 , 3 , J)  ♦  WIJ(3) »HIR(3,3,J) 
CSB  =  EFUNCT (ANGL (3) ,RB,SPRING(1 ,3*J-1) , JSTP) 

IF  (NJ.EQ.O)  JSTOP (2, 1 , J)  =  JSTP 
IF  (NJ.GT.O)  GO  TO  34 

COMPUTE  EFFECT  OF  GLOBALGRAPHIC  JOINT  STOP  (IPIN=3) 

27  IF  (IPIN(J) . NE.3)  GO  TO  34 

CALL  GLOBAL  ( J ,HD3 ( 1 . 3) ,DH1 ,TQC ,T9 , ANGL) 

COMPUTE  TOTAL  TORQUE  IN  INERTIAL  REFERENCE  BY 
TQ  =  -CV»WIJ  +  CSA»T7  ♦  CSB»T8  ♦  TQC*T9 

34  IF  (NJ.EQ.O)  GO  TO  35 
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CV  =  0.0  VISPR 

IF  (IJ.HE.l)  CSA  =  0.0  VISPR 

IF  (IJ.NE.2)  CSB  =  0.0  VISPR 

IF  (IJ.HE.4)  TOC  =  0.0  VISPR 

35  IF  (HA(2,2»J) .EQ.O.O)  GO  TO  36  JDRIFT 

CALL  MAT31  (HIR( 1 , 1 , J) ,HA ( 1 , 2»J-1) ,TQ ( 1 , J) )  VISPR 

DO  38  L= I , 3  VISPR 

38  TQ ( L , J )  =  HA(2,2»J)«TQ(L,J)  VISPR 

36  DO  37  L= 1 , 3  VISPR 

TQ(L, J)  =  TQ(L, J)  -CV*WIJ(L)  +CSA*T7(L)  +CSB«HIR(L,3, J)  *TQC#T9 (L) VISPR 

37  TTI(L)  =  TQ(L,J)  VISPR 

IF  (NPRT(12) .NE.O)  WRITE  (6,39)  VISPR 

*  J ,CV,CSA,CSB,HAC ,RA,RB, (TQ(L,J) ,L=1 ,3) ,  VISPR 

«  WIJ.T7.ANGL.  DH1  ,  HD3,  VISPR 

»  ( (HIR(L,K, J) , L=1 ,3) ,K=1 ,3)  VISPR 

39  FORMAT  ( 1H0 . 13 . 3F14 . 3 ,6F14 . 6/ (4X.9F14.6) )  VISPR 

VISPR 

ADD  TORQUE  CONVERTED  TO  LOCAL  REFERENCE  BT  VISPR 

U2I  =  U2I  +  DI«TQ  VISPR 

U2J  =  U2J  -  DJ*TQ  VISPR 

VISPR 

DO  40  L= 1 , 3  VISPR 

DO  40  M=1 ,3  VISPR 

U2  (L ,  I  )  =  U2(L,I  )  +  D(L,M,  I  )#TQ(1(,J)  VISPR 

40  U2(L, J+l)  =  U2 (L , J  + 1 )  -  D(L,M, J*l) »TQ(M, J)  VISPR 

VISPR 

STORE  DATA  FOR  OUTPUT  ROUTINE  INTO  PRJNT  ARRAY.  VISPR 

VISPR 

41  PRJNT ( 1 , J)  =  IPIN(J)  VISPR 

PRJNT (2 ,J)  =  ANGL(l)  VISPR 

PRJNT (3 , J)  =  ANGL ( 2 )  VISPR 

PRJNT  (4,  J)  =  ANGLO)  VISPR 

PRJNT ( 5 , J )  =  (CSA«HAC) *«2  +  CSB«*2  VISPR 

PRJNT (6 , J)  =  (CV»WI JM) »«2  VISPR 

PRJNT (7 , J)  =  TQ(1,J)»#2  ♦  TQ(2,J)««2  ♦  TQ(3,J)««2  VISPR 

90  CONTINUE  VISPR 

CALL  ELTIME(2 , 13)  VISPR 

99  RETURN  VISPR 


SUBROUTINE  WINDY (MMM, MM, N ,NN , NT)  WINDY 

REV  IV  07/23/86TW0PI 

COMPUTES  FORCES  AND  TORQUES  ADDING  THEM  TO  THE  U1  AND  U2  ARRAYS  WINDY 
OF  WIND  BLAST  FORCES  DETERMINED  BY  FUNCTION  STORED  IN  TAB (NT)  WINDY 

ON  ELLIPSOID  (MM)  ATTACHED  TO  BODY  SEGMENT  (M)  WHICH  EXTENDS  WINDY 

THROUGH  THE  INTERSECTING  PLANE  (NN)  ATTACHED  TO  SEGMENT  (N) .  WINDY 

WINDY 

IMPLICIT  REAL*8  (A-H.O-Z)  WINDY 

COMMON/CONTRL/  TIME , NSEG , NJNT , NPL ,NBLT , NBAG , NVEH , NGRND ,  WINDY 

»  NS ,NQ , NSD ,NFLX , NHRNSS , NWINDF .NJNTF ,NPRT (36) ,NPG  PAGE 

COMMON/ SGMNTS/  D(3.3,30) ,WMEG(3,30) ,WMEGD(3,30) ,U1(3,30) ,U2(3,30) .WINDY 

*  SEGLP(3,30) ,SEGLV(3,30) ,SEGLA(3,30) ,NSYM(30)  WINDY 

COMMON/TABLES/MXNTI . MXNTB , MXTB 1 , MXTB2 , NTI (50) , NTAB ( 1250) . TAB (4500 ) DIMENB 
COMMON/ WINDFR/  WTIME(30) ,QFU(3,5) ,QFV(3,5) ,WF(3,30) ,IWIND(30) .  WINDOP 

»  MWSEG(7,30)  ,NFVSEG(6) ,NFVNT(5) ,MOWSEG(30 , 30)  WINDOP 

COMMON/CNTSRF /  PL (24 , 30) . BELT (20 , 8) ,TPTS (6 ,8) ,BD(24 , 40)  EDGE 

COMMON/CNSNTS/  PI .RADIAN, G,THIRD,EPS(24) ,  WINDY 

*  UNITL .UNITM.UNITT .GRAVTY (3) .TWOPI  TWOPI 

COMMON/TEMP VS/  DMNT(3,3) ,XMN(3) ,XMM(3) ,TM(3) ,BET,BTS,P,FT(3) ,  WINDOP 

*  FF ( 3 ) . AF ( 3 ) , FAF , TF , BREF , SCALE , TRACER , AREA , RLM ( 3 ) ,  WINDOP 

*  TQM(3) ,RM(3) ,DD(3,3) ,DDD(3,3) ,R(3,3) ,DVP(3,3) ,  WINDOP 

*  SI (3 . 15) ,R2(2,3) ,TTF(3) ,FFT(3) ,AM(3,3) ,VP(3) ,  WINDOP 

*  SS ( 3 ) ,SM(3) ,SN1(3) ,AS(3) , BTE , XNORM , TEMP ,  WINDOP 

*  X,Y.AI(3,3.15) .RYC.AMDA1.AMDA2.B1.B2.RXC  WINDOP 

WINDOP 

MMM=0  CALCULATE  NFORCE  WINDOP 

MMM>0  WIND  FORCE  CALCULATED  USING  ENTIRE  AREA  METHOD  WINDOP 

MMMCO  WIND  FORCE  CALCULATED  USING  GRID  METHOD  WINDOP 

(ALLOWS  BLOCKING  SEGMENTS)  WINDOP 

WINDOP 

DATA  NSTEPS/4/  WINDOP 

CALL  ELTIME (1,37)  WINDY 

M- IABS (MMM)  WINDOP 

IF  (MMM. EQ . 0)  GO  TO  50  WINDOP 

WINDY 

COMPUTE  PENETRATION  DISTANCE;  IF  NEGATIVE,  RETURN.  WINDY 

WINDY 

CALL  D0TT33  ( D ( 1 , 1 . M) ,D ( 1 , 1 ,N) , DMNT)  WINDY 

DO  10  1=1,3  WINDY 

10  XMN(I)  =  SEGLP(I.M)  -  SEGLP(I.N)  WINDY 

CALL  MAT31  (D( 1 , 1 ,M) , XMN.XMM)  WINDY 

CALL  MAT31  (DMNT, PL ( 1 , NN) , TM)  WINDY 

BET  =  PL(4 ,NN)  WINDY 

DO  11  1=1,3  WINDY 

11  BET  =  BET  -  TM( I ) * (BD ( I +3 , MM) +XMM( I ) )  WINDY 

CALL  MAT31  (BD ( 16 , MM) ,TM, RM)  WINDY 

BTS  =  TM( 1 ) #RM( 1 )  +  TM(2) »RM(2)  +  TM(3)*RM(3)  WINDY 

BTE  =  -DSQRT(BTS)  WINDY 

P  =  BET  -  BTE  WINDY 

IF  (P.LT.O.O)  GO  TO  99  WINDY 
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12 

13 

FETCH  OR  STORE  INITIAL  PENETRATION  TIME. 

IWIND(M)  =  M 

IF  (TIME . LE . WTIME (M) )  WTIME (M)  =  TIME 
FTIME  =  TIME  -  WTIME (M) 

GET  DRAG  COEFFICIENT  CD  FROM  TABLE  NTC  FOR  TIME  =  FTIME. 
CD= 1 . 0 

NTC=MWSEG(6 ,M) 

IF  (NTC.EQ.O)  GOTO  20 
KT=NTI (NTC) 

NENTRY=TAB (KT+5) 

K1=KT+ 10 

K2=4*NENTRY+KT+2 

IF  (NENTRY.EQ. 1)  GOTO  18 

DO  17  K=K1 ,K2 , 4 

IF  (FTIME. GT. TAB (K))  GOTO  17 

KK=K 

Rl= (TAB (K) -FTIME) / (TAB(K) -TAB(K-4) ) 

GOTO  19 
CONTINUE 
KK  =  K2 
R1  =  0 . 0 
R22=  1 . 0-R1 
K=KK+ 1 

CD=R22*TAB(K)+Rl»TAB(K-4) 

GET  FORCE  VECTOR  FT 

RK=0  TIME  DEPENDENT  WIND  FORCE  FROM  TABLE 
RK*0  VELOCITY  DEPENDENT  WIND  FORCE 

KT  =  NTI (NT) 

RK=TAB (KT) 

IF  (RK.EQ.O.O)  GOTO  13 
C=TAB (KT+ 1 ) 

PR=TAB (KT+2) 

NSV= IDINT (TAB (KT+3) ) 

NSR=IDINT(TAB(KT+4) ) 

DO  12  1=1,3 

V=SEGLV ( I , NSV) -SEGLV ( I ,NSR) 

FT ( I ) =DSIGN(0 . 5D0 , -V) *CD»RK*PR»V«»2/C»*2 
GOTO  14 

NSR= IDINT (TAB (KT+4) ) 

NENTRY  =  TAB (KT+5) 

K1  =  KT+10 

K2  =  4 » NENTRY  ♦  KT+2 

IF  (NENTRY.EQ. 1)  GO  TO  31 
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DO  30  K=K1 ,K2 ,4  WINDY 

IF  (FTIME.GT.TAB(K) )  GO  TO  30  WINDY 

KK  =  K  WINDY 

Ri  =  (TAB(K) -FTIME) / (TAB(K) -TAB(K-4) )  WINDY 

GO  TO  32  WINDY 

30  CONTINUE  WINDY 

31  KK  =  K2  WINDY 

Rl  =  0.0  WINDY 

32  R22=  1.0  -  Rl  WINDOP 

DO  33  1=1,3  WINDY 

K=  KK+I  WINDY 

33  FT ( I ) = (R22#TAB(K)  +  Rl*TAB(K-4) ) *CD  WINDOP 

IF  (NSR.EQ.O)  GOTO  14  WINDOP 

CALL  D0T31 (D( 1 , 1 ,NSR) ,FT ,FF)  WINDOP 

DO  21  1=1,3  WINDOP 

FT (I) =FF(I)  WINDOP 

IF  (MMM.LT.O)  GOTO  15  WINDOP 

WINDY 

COMPUTE  PRESENTED  AREA  TO  WIND  FORCE.  WINDY 

WINDY 

CALL  MAT31  (D( 1 , 1 ,M) ,FT,FF)  WINDY 

CALL  MAT31  (BD(7,MM) .FF.AF)  WINDY 

FAF  =  FF ( 1 ) * AF ( 1 )  +  FF(2)*AF(2)  ♦  FF(3)*AF(3)  WINDY 

IF  (FAF. LE. 0.0)  GO  TO  99  WINDY 

TF  =  TM(1)#FF(1>  +  TM(2) »FF (2)  ♦  TM(3)»FF(3)  WINDY 

BREF=0 .0  CCWIND 

TEMP=BTS-TF*TF/FAF  CCWIND 

IF (TEMP. GT. 0.0)  BREF  =DSQRT(TEMP)  CCWIND 

SCALE  =  (-BET+BREF) / (-BTE+BREF)  WINDY 

IF  (SCALE. GE. 1.0)  GO  TO  99  WINDY 

IF  (SCALE. LT. 0.0)  SCALE  =  0.0  WINDY 

TRACER  =  (BD (  7 ,MM) -AF ( 1) *»2/FAF) * (BD( 1 1 ,MM) -AF (2) **2/FAF)  WINDY 

*  +  (BD (  7 , MM) -AF ( 1 ) »»2/FAF) » (BD ( 15 ,MM) -AF (3) *#2/FAF)  WINDY 

*  +  (BD(  1 1 . WOW)  -  AF(2)  ««2/FAF)  «  (BD( 15 ,MM)  -AF(3) **2/FAF)  WINDY 

»  -  (BD (  8 ,MM) -AF ( 1 ) «AF (2) /FAF) « *2  WINDY 

»  -  (BD (  9 ,MM) -AF (1)*AF(3)/FAF)#»2  WINDY 

»  -  (BD ( 12 ,MM) -AF (2) *AF(3) /FAF) *«2  WINDY 

AREA  =  (1.0-SCALE*»2)  «  PI  /  DSQRT (TRACER)  WINDY 

WINDY 

ADD  FORCE  AND  TORQUES  TO  U1  AND  U2  ARRAYS  FOR  SEGMENT  M.  WINDY 

WINDY 

SCALE  =  SCALE/BTE  WINDY 

DO  36  1=1,3  WINDY 

RLM(I)  =  RM(I) »SCALE  +  BD(I+3,MM)  WINDY 

FT  (I)  =  FT ( I ) *AREA  WINDY 

36  FF  (I)  =  FF ( I ) *AREA  WINDY 

CALL  CROSS  (RLM.FF.TQM)  WINDY 

DO  39  1=1,3  WINDY 

WF ( I ,M) =FT ( I)  WINDOP 

Ul(I.M)  =  Ul(I.M)  ♦  FT (I)  WINDY 


39  U2(I,M)  =  U2 ( I ,M)  +  TQM(I)  WINDY 

IF  (NPRT(14) .NE.O)  WRITE  (6,41)  TIME ,M,P, AREA, FT, TQM  WINDY 

41  FORMAT ( ’  WIND  FORCE' ,F14 . 6 , 16 , 2F10 . 3 , 3X.3F12 . 5 , 3X, 3F12 . 5)  WINDY 

GO  TO  99  WINDY 

C  WINDY 

C  USE  GRID  TO  CALCULATE  WIND  FORCE  WINDOP 

C  VP  -  ORIGIN  OF  WIND  WINDOP 

C  WINDOP 

15  ARE AT =0.0  WINDOP 

DO  16  1=1,3  WINDOP 

TTF ( I ) =0 . 0  WINDOP 

TQM(I) =0 .0  WINDOP 

16  VP(I)  =  -FT ( I ) » 10000 . 0  WINDOP 

TEMP=FT ( 1 ) **2+FT (2) #*2+FT (3) *«2  WINDOP 

IF  (TEMP. EQ. 0.0)  GOTO  99  WINDOP 

CALL  MAT31 (D( 1 , 1 ,M) ,FT,FF)  WINDOP 

TEMP  =0.0  WINDOP 

IF  (FT ( 1 ) .NE.O. 0. OR. FT(2) .NE.O. 0)  GOTO  150  WINDOP 

C  WINDOP 

C  CALCULATE  DIRECTION  COSINE  MATRIX  FOR  VP  COORD.  SYS.  WINDOP 

C  WINDOP 

DO  140  1=1,3  WINDOP 

DO  140  J= 1 ,3  WINDOP 

140  DVP ( I , J) =0 . 0  WINDOP 

DTP (1,2)31.0  WINDOP 

DVP (2 , 1 ) = 1 . 0  WINDOP 

DVP (3, 3) =-1.0  WINDOP 

GO  TO  141  WINDOP 

150  CONTINUE  WINDOP 

DO  110  1=1,3  WINDOP 

110  TEMP=TEMP+FT ( I ) *FT ( I )  WINDOP 

TEMP  =  DSQRT (TEMP)  WINDOP 

XNORM  =  DSQRT (FT ( 1 ) *  FT ( 1 ) /TEMP*»2+FT (2) »FT(2) /TEMP»*2)  WINDOP 

DVP (1,1)  =  FT ( 2 ) / ( XNORM*TEMP )  WINDOP 

DVP (1,2)  =  -FT(1)/ (XNORM* TEMP)  WINDOP 

DVP (1,3)  =  0.0  WINDOP 

DVP (2,1)  =  FT ( 1 ) «FT (3) / (XNORM» TEMP » TEMP)  WINDOP 

DVP (2 , 2)  =  FT(2) »FT (3) / (XNORM#TEMP»TEMP)  WINDOP 

DVP (2, 3)  =  -XNORM  WINDOP 

DO  130  1=1,3  WINDOP 

130  DVP (3, I)  =  FT ( I ) /TEMP  WINDOP 

141  CONTINUE  WINDOP 

MOELP  =  MWSEG(7,M)  WINDOP 

C  WINDOP 

C  PROJECT  MM  ELLIPSOID  UNTO  VP-PLANE  WINDOP 

C  AS  -  PROJECTED  ELLIPSE  MATRIX  WINDOP 

C  WINDOP 

CALL  D0TT33 ( D ( 1 , 1 , M) , DVP , DD )  WI NDOP 

CALL  MAT33(BD(7,MM) ,DD,DDD)  WINDOP 

CALL  D0T33 (D( 1 , 1 ,M) ,DDD,DD)  WINDOP 


CALL  MAT33(DVP,DD,AM) 

DO  101  K= 1 ,3 

SS  <K) =SEGLP(K,M) +BD (K+3 ,MM) -VP (K) 

CALL  MAT3KDVP.SS.SM) 

DO  114  K= 1 , 3 

IF  (DABS(SM(K) ) .LT.EPS(5) )  SM(K) =DSIGN (EPS (5) , SM(K)) 

CONTINUE 

CALL  SOLVE (AM( 1,1) ,AM(2,1) ,AM(3,1) ,AM(1,3) ,AM(2,3) ,AM(3,3) , 

*  AM (1,1) , AM( 1,3) , SM,R( 1 , 1) ,R(3, 1) ) 

CALL  SOLVE (AM( 1,2) ,AM(2,2) ,AM(3,2) ,AM(1,3) ,AM(2,3) ,AM(3,3) , 

*  AM(2 ,2) , AM ( 2 , 3 ) ,SM.R(2,2) ,B(3,2)) 

CALL  SOLVR(AM( 1,1) +AM( 1,2) , AM(2 , 1) +  AM(2 , 2) ,  AMU ,  1)  *AM(3 . 2) , 

»  AM( 1 ,3) , AM(2 ,3) ,AM(3,3) , AM( 1 , 1) +2.0»AM(1 ,2) +AM(2 ,2) 

*  AM( 1 ,3) +AM(2 , 3) ,SM,R(1,3) ,R(3,3)) 

R (2 , 1 ) =0 . 0 

R ( 1 , 2) =0 . 0 
R(2 ,3) =R( 1 ,3) 

DO  102  K= 1 , 3 
DO  102  J= 1 , 2 
R2 ( J ,K) =R( J ,K) 

CALL  S0LVA(R2 ,AS ( 1) , AS ( 2 ) , AS ( 3 ) ) 

GET  MAJOR  &  MINOR  AXES  OF  PROJECTED  ELLIPSE 

TEMP=(AS(1)+AS(2) )  ««2-4 . 0* (AS (1 ) *AS (2) -AS (3) «*2) 

IF  (TEMP. LT. 0.0)  TEMP=0.0 
TEMP  =  DSQRT (TEMP) 

AMDA1= (AS ( 1 ) +AS (2) +TEMP) /2 . 0 
AMDA2= ( AS ( 1 ) +AS (2) -TEMP) /2 . 0 
R2 ( 1 , 1 ) =AS (3) 

R2 (2 , 1 ) =AMDA1-AS ( 1 ) 

R2 ( 1 ,2) =AMDA2-AS (2) 

R2 (2 , 2) =AS (3) 

AMDA 1  =  DABS ( AMDA 1 ) 

AMD A2 = DABS (AMDA2) 

B1=DSQRT (1.0/ (AMDA1 * (R2(ltl)**2+R2(l,2)**2))) 

B2= DSQRT (1.0/ (AMDA2* (R2 (2 , 1 ) »*2+R2 (2 , 2) «»2) ) ) 

R2 ( 1 , 1) =R2 (1,1) *B1 
R2( 1 ,2) =R2(1 ,2) »B2 
R2  (2 , 1 ) =R2 (2 , 1 ) »B1 
R2 (2 , 2) =R2 (2,2) *B2 

GET  BLOCKING  ELLIPSOIDS  IN  VP  COORD.  SYS. 

DO  103  MI = 1 , MOELP 
I=M0WSEG(M,MI*2-1) 

II=M0WSEG(M,MI*2) 

CALL  D0TT33 (D ( 1,1,1) ,DVP ,DD) 

CALL  MAT33(BD(7,II) , DD.DDD) 

CALL  D0T33 (D( 1 , 1 , I ) ,DDD,DD) 
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CALL  MAT33 (DVP , DD , AI ( 1 , 1 ,MI) ) 

DO  104  K=  1 ,3 

SS (K) =SEGLP (K , I) +BD (K+3 , I I) -VP (K) 

CALL  MAT3 1 ( DVP ,SS,SI(1,MI)) 

DO  115  K= 1 , 3 

IF  (DABS (SI (K ,MI) ) . LT. EPS (6) )  SI (K , MI) =DSIGN(EPS (6) ,SI (K.MI) ) 

CONTINUE 

CONTINUE 

SET-UP  GRID  AND  CHECK  EACH  RECTANGLE  CENTER  POINT 

AREA=DSQRT( (R2(l , 1 ) »*2+R2 (2 , 1 ) »*2) « (R2 ( 1 , 2) »«2+R2 (2 , 2) *»2) ) 
AREA=  AREA/ NSTEPS  *  #  2 
IN-2*NSTEPS+ 1 
DO  105  1=1, IN 

RXC  =  R2 ( 1 , 1 ) -R2 ( 1 . 1 ) * ( I - 1 ) /NSTEPS 
RYC  =  R2 ( 2 . 1 ) -R2 ( 2 , 1 ) * ( I - 1 ) /NSTEPS 
DO  106  J= 1 ,  IN 

RM ( 1 ) = (RXC-R2 (1.2)* (NSTEPS- J+ 1) /NSTEPS) «0 . 9999 
RM ( 2 ) = (RYC-R2 (2 ,2) * (NSTEPS- J+ 1 ) /NSTEPS) »0 . 9999 
TM( 1 ) =AM(3 ,3) 

TM(2) =2 . 0* (RM( 1 ) *AM( 1,3) +RM(2) *AM(2 , 3) ) 

TM(3)=RM(1)»*2*AM(1, 1) ♦RM(2) **2*AM(2 , 2) *2. 0»RM( 1 ) *RM(2) «AII( 1.2) 
TEMP=TM(2)**2-4.0*TM(1)*TM(3) 

IF  (TEMP. LT. 0.0)  GOTO  106 

B1 = (DSQRT (TEMP) -TM(2) ) / (2 . 0*TM( 1) ) 

B2=- (DSQRT(TEMP) +TM(2) ) / (2.0»TM(1) ) 

RM(3) =B1 

IF  (B2.LT.B1)  RM(3) =B2 
SN1 ( 1) =RM( 1) +SM( 1) 

SN1 (2) =RM(2) +SM(2) 

SN1 (3) =RM(3) +SM(3) 

CALL  D0T3 1 ( DVP . SN 1 , XMM) 

CHECK  FOR  PENETRATION 

DO  107  K=  1 , 3 

XMN(K) =VP(K) -SEGLP(K.N) +XMM(K) 

CALL  MAT31 (D(l , 1 ,N) , XMN.XMM) 

BET=PL(4,NN) 

BTS=PL ( 1  ,NN)  »XMM(  1 )  +PL (2  ,NN)  *XMM(2)  ♦  PLO , NN'  *XMM(3) 

IF  (BTS.GT.BET)  GOTO  106 

CHECK  FOR  BLOCKING  ELLIPSOIDS 

DO  109  IM= 1 , MOELP 
X=SN1 ( 1 ) -SI ( 1 , IM) 

Y=SN1 (2) -SI (2 , IM) 

TM( 1 ) =AI (3,3 , IM) 

TM( 2) =2 . 0» ( AI ( 1 , 3 , IM) »X+AI (2 , 3 , IM) »Y) 
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TM(3)=AI(l,l,IM)*X**2+AI(2,2,IM)*Y**2+2. 0»AI (1,2,1 M) »X*Y- 1 . 0 
TEMP=TM(2) *»2-4 . 0*TM( 1) «TM(3) 

IF  (TEMP. LT. 0.0)  GOTO  109 
B 1 = ( -TM(2) +DSQRT (TEMP) ) / (2 . 0»TM( 1) ) 

B2  = (-TM(2) -DSQRT(TEMP) ) / (2.0»TM(1) ) 

IF  (B2.LT.B1)  B1=B2 
SNZ=B1+SI (3. IM) 

IF  (SNZ.LT.SN1 (3) )  GOTO  106 
CONTINUE 

CALL  DOT31 (DVP.RM.SS) 

CALL  MAT3 1 (D ( 1 , 1 , M) , SS , RM) 

SUM  FORCES  &  TORQUES 

AREAT = AREAT + AREA 

DO  111  K=1 ,3 

TTF (K) =FT (K) *AREA+TTF (K) 

RM(K) =RM(K) +BD (K+3 ,MM) 

FFT (K) =FF (K) »AREA 
CALL  CROSS (RM. FFT, TM) 

DO  112  K= 1 , 3 
TQM(K) =TQM(K) +TM(K) 

CONTINUE 

CONTINUE 

ADD  FORCE  &  TORQUE  TO  U1  &  U2  ARRAYS  FOR  SEGMENT  M 

IF  (NPRT (14) . NE . 0)  WRITE(6.200)  TIME. M, AREAT .TTF. TQM 
FORMAT ( ’  WIND  FORCE ’ ,F14 . 6 , 16 , 13X.F10 . 3 ,3F12 . 5 .3X.3F12 . 5) 

DO  113  1=1,3 
WF ( I ,M) =TTF ( I ) 

U1(I,M)=U1(I,M) +TTF ( I ) 

U2 ( I ,M) =U2 ( I ,M) +TQM( I ) 

GO  TO  99 

M  =  0:  CALCULATE  FORCE  FUNCTIONS. 

NFORCE  =  NFVSEG(6) 

DO  60  J=l, NFORCE 
NFS  =  IABS (NFVSEG( J) ) 

NFT  =  I ABS ( NFVNT ( J ) ) 

KFT  =  NTI(NFT) 

FRCE  =  EVALFD (TIME, KFT, 1) 

IF  (NFVSEG(J) .GT.O)  GO  TO  52 
DO  51  1=1,3 

U2 ( I .NFS)  =  U2 (I .NFS)  +  FRCE»QFU(I , J) 

GO  TO  60 

CALL  DOT31  (D ( 1 . 1 , NFS) ,QFU( 1 , J) ,TM) 

DO  53  1=1,3 

U 1 ( I .NFS)  =  U 1 ( I .NFS)  ♦  FRCE*TM(I) 


WINDOP 

WINDOP 

WINDOP 

WINDOP 

WINDOP 

WINDOP 

WINDOP 

WINDOP 

WINDOP 

WINDOP 

WINDOP 

WINDOP 

WINDOP 

WINDOP 

WINDOP 

WINDOP 

WINDOP 

WINDOP 

WINDOP 

WINDOP 

WINDOP 

WINDOP 

WINDOP 

WINDOP 

WINDOP 

WINDOP 

WINDOP 

WINDOP 

WINDOP 

WINDOP 

WINDOP 

WINDOP 

WINDOP 

WINDOP 

WINDOP 

WINDOP 

WINDY 

WINDY 

WINDY 

WINDY 

WINDY 

WINDY 

WINDY 

WINDY 

WINDY 

WINDY 

WINDY 

WINDY 

WINDY 

WINDY 


53  U2 ( I .NFS)  = 
60  CONTINUE 
99  CALL  ELTIME 
RETURN 
EN 


DOUBLE  PRECISION  FUNCTION  XDY(X,D,Y) 
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FUNCTION  ROUTINE  TO  COMPUTE  X.DY  OR  Y.D’X 


IMPLICIT  REAL»8 (A-H.O-Z) 

DIMENSION  X(3) ,D(3,3) ,Y(3) 

XDY  =  0.0 
DO  10  1=1,3 

10  XDY  =  XDY  +  X(I)*(D(I,1)»Y(1)*D(I,2)«Y(2)*D(I,3)«Y(3)) 
RETURN 
END 
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SUBROUTINE  YPRDEG(D.A) 

REV  IV 

COMPUTES  YAW  PITCH  AND  ROLL  IN  DEGREES  AND  PLACES  THEM 
INTO  THE  A  ARRAY  FOR  A  GIVEN  DIRECTION  COSINE  MATRIX 


ASSUMES  D  =  D(R) D (P) D (Y)  ,  WHERE 


D  (R)  = 


0  0 
CR  SR 
-SR  CR 


,D(P)  = 


AND  D(Y)  = 


CY  SY  0 
-SY  CY  0 
0  0  1 


IMPLICIT  REAL*8(A-H,0-Z) 

DIMENSION  A(3) ,D(3,3) 

COMMON/CNSNTS/  PI .RADIAN ,G, THIRD , EPS (24)  , 

«  UNITL , UNITM, UNITT , GRAVTY(3) .TWOPI 

IF  (DABS (D( 1,1)) .LE.EPS(IS) . AND . DABS (D ( 1 ,2) ) . LE.EPS(15) ) 
IF  (DABS (D (2. 3) )  ,LE.EPS(15)  .  AND. DABS (D (3, 3) )  ,LE.EPS(15) ) 
YAW  =  DATAN2 (D ( 1 , 2) ,D(1,1)) 

ROLL  =  DATAN2 ( D ( 2 , 3 ) , D ( 3 , 3 ) ) 

GO  TO  11 

10  YAW  =  DATAN2 (-D (2 , 1 ) ,D (2 , 2) ) 

ROLL  =0.0 

11  PITCH  =  -DASIN(D ( 1,3)) 

IF  (DABS (ROLL) .LE.0.5«PI)  GO  TO  20 
IF  (DABS (YAW  ).LE.0.5#PI)  GO  TO  20 
PITCH  =  DSIGN(PI-DABS (PITCH) .PITCH) 


YAW  = 
ROLL  = 
20  A ( 1 )  = 
A  ( 2 )  = 
A(3)  = 
RETURN 
END 


DATAN2 ( -D ( 1 , 2) ,-D(l,l)) 
DATAN2(-D(2,3) ,-D(3,3)) 
YAW/ RAD I AN 
PITCH/RADIAN 
ROLL /RAD I AN 
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GOTO 10  YPRFIX 

GOTO 10  YPRFIX 
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